pict: Add pict->file.

* pict.scm (pict->file): New procedure.

1 files changed, 16 insertions, 1 deletions

diff --git a/pict.scm b/pict.scm
index 579cde3..58d3394 100644
--- a/pict.scm
+++ b/pict.scm
@@ -37,7 +37,7 @@
             pict-width
             pict-height
             pict-rotation
-
+            pict->file
             pict-from-file
 
             ;; modifiers
@@ -117,6 +117,21 @@
   pict?
   (sxml pict-sxml))
 
+(define (pict->file pict file-name)
+  "Write the PICT to a file with name FILE-NAME.  If FILE-NAME is a
+procedure, it is called with the XML that is supposed to be written to
+the file to determine the file name.  Return the file name."
+  (let* ((xml (with-output-to-string
+                (lambda _ (sxml->xml `(svg (@ (width ,(pict-width pict))
+                                         (height ,(pict-height pict))
+                                         (xmlns "http://www.w3.org/2000/svg"))
+                                      ,(pict-sxml pict))))))
+         (name (if (procedure? file-name)
+                   (file-name xml) file-name)))
+    (with-output-to-file name
+      (lambda _ (display xml)))
+    name))
+
 ;; XXX: This is a hack to let Geiser display the image.
 ;; Since Geiser only supports the display of images that are
 ;; associated with a file we write out the SVG to a temp file and