diff --git a/collects/racket/draw/private/post-script-dc.rkt b/collects/racket/draw/private/post-script-dc.rkt
index e88738d973..f896c0fc9a 100644
--- a/collects/racket/draw/private/post-script-dc.rkt
+++ b/collects/racket/draw/private/post-script-dc.rkt
@@ -40,7 +40,7 @@
                   (output-port? output))
         (raise-type-error (get-name) "path string, output port, or #f" output)))
 
-    (define-values (s port-box close-port? width height landscape?)
+    (define-values (s port close-port? writer width height landscape?)
       (let ([su (if interactive
                     ((gui-dynamic-require 'get-ps-setup-from-user) #f parent)
                     (current-ps-setup))])
@@ -68,7 +68,7 @@
                          #f)])
             (if (and to-file?
                      (not fn))
-                (values #f #f #f #f #f #f)
+                (values #f #f #f #f #f #f #f)
                 (let* ([paper (assoc (send pss get-paper-name) paper-sizes)]
                        [w (if (or (not init-w) use-paper-bbox)
                               (cadr paper)
@@ -83,26 +83,26 @@
                                   (or fn (make-temporary-file (if pdf?
                                                                   "draw~a.pdf"
                                                                   "draw~a.ps")))
-                                  #:exists 'truncate/replace))]
-                       [port-box (make-immobile file)])
+                                  #:exists 'truncate/replace))])
                   (let-values ([(w h) (if (and pdf? landscape?)
                                           (values h w)
-                                          (values w h))])
+                                          (values w h))]
+                               [(writer proc) (make-port-writer file)])
                     (values
                      ((if pdf?
                           cairo_pdf_surface_create_for_stream 
                           cairo_ps_surface_create_for_stream)
-                      write_port_bytes
-                      port-box
+                      proc
                       w
                       h)
-                     port-box ; needs to be accessible as long as `s'
+                     file
                      (not (output-port? fn))
+                     writer
                      w
                      h
                      landscape?)))))]
          [else
-          (values #f #f #f #f #f #f)])))
+          (values #f #f #f #f #f #f #f)])))
 
     (define-values (margin-x margin-y)
       (if as-eps
@@ -147,9 +147,11 @@
       (cairo_destroy c)
       (set! c #f)
       (set! s #f)
+      (port-writer-wait writer)
+      (set! writer #f)
       (when close-port?
-        (close-output-port (ptr-ref port-box _racket)))
-      (set! port-box #f))
+        (close-output-port port))
+      (set! port #f))
 
     (define/override (init-cr-matrix c)
       (cairo_translate c trans-x trans-y)
diff --git a/collects/racket/draw/private/svg-dc.rkt b/collects/racket/draw/private/svg-dc.rkt
index c761f4e34b..7feb052de8 100644
--- a/collects/racket/draw/private/svg-dc.rkt
+++ b/collects/racket/draw/private/svg-dc.rkt
@@ -40,16 +40,17 @@
     (define height init-h)
     (define close-port? (path-string? init-output))
 
-    (define port-box ; needs to be accessible as long as `s' or `c'
-      (let ([output (if (output-port? init-output)
-                        init-output
-                        (open-output-file init-output #:exists exists))])
-        (make-immobile output)))
-    (define s (cairo_svg_surface_create_for_stream 
-               write_port_bytes
-               port-box
-               width
-               height))
+    (define port
+      (if (output-port? init-output)
+          init-output
+          (open-output-file init-output #:exists exists)))
+    (define-values (s writer)
+      (let-values ([(writer proc) (make-port-writer port)])
+        (values (cairo_svg_surface_create_for_stream 
+                 proc
+                 width
+                 height)
+                writer)))
 
     (define c (and s (cairo_create s)))    
     (when s (cairo_surface_destroy s))
@@ -66,9 +67,11 @@
       (cairo_destroy c)
       (set! c #f)
       (set! s #f)
+      (port-writer-wait writer)
+      (set! writer #f)
       (when close-port?
-        (close-output-port (ptr-ref port-box _racket)))
-      (set! port-box #f))
+        (close-output-port port))
+      (set! port #f))
 
     (define/override (get-pango font)
       (send font get-pango))
diff --git a/collects/racket/draw/private/write-bytes.rkt b/collects/racket/draw/private/write-bytes.rkt
index 9946b1673e..ee03ed5d8d 100644
--- a/collects/racket/draw/private/write-bytes.rkt
+++ b/collects/racket/draw/private/write-bytes.rkt
@@ -4,14 +4,25 @@
          "../unsafe/cairo.ss"
          "../unsafe/bstr.ss")
 
-(provide write_port_bytes
-         make-immobile)
+(provide make-port-writer
+         port-writer-wait)
 
-(define (write-port-bytes port-box bytes len)
-  (write-bytes (scheme_make_sized_byte_string bytes len 0) 
-               (ptr-ref port-box _racket))
-  CAIRO_STATUS_SUCCESS)
+(define (make-port-writer port) 
+  (let ([t (thread/suspend-to-kill
+            (lambda ()
+              (let loop ()
+                (let ([msg (thread-receive)])
+                  (when (bytes? msg)
+                    (write-bytes msg port)
+                    (loop))))))])
+    (values t
+            (lambda (bytes len)
+              (thread-send t (scheme_make_sized_byte_string bytes len 1) 
+                           void)
+              CAIRO_STATUS_SUCCESS))))
 
-(define write_port_bytes (function-ptr write-port-bytes _cairo_write_func_t))
+(define (port-writer-wait t)
+  (thread-resume t)
+  (thread-send t eof void)
+  (thread-wait t))
 
-(define make-immobile ((allocator free-immobile-cell) malloc-immobile-cell))
diff --git a/collects/racket/draw/unsafe/cairo.rkt b/collects/racket/draw/unsafe/cairo.rkt
index 8522e8a756..c60c959adc 100644
--- a/collects/racket/draw/unsafe/cairo.rkt
+++ b/collects/racket/draw/unsafe/cairo.rkt
@@ -237,21 +237,44 @@
   #:wrap (allocator cairo_surface_destroy))
 (define-cairo cairo_ps_surface_create (_fun _path _double* _double* -> _cairo_surface_t)
   #:wrap (allocator cairo_surface_destroy))
-(define-cairo cairo_ps_surface_create_for_stream 
-  ;; The _fpointer argument is _cairo_write_func_t
-  ;; but it's saved as a callback, so care is needed with
-  ;; allocation.
-  (_fun  _fpointer _pointer _double* _double* -> _cairo_surface_t)
-  #:wrap (allocator cairo_surface_destroy))
+
+;; Stream surfaces
+
+;;  The first argument to a stream-surface creation
+;;  function is a procedure, and we need the procedure to
+;;  live just as long as the surface. Implement that by
+;;  saving the closure via user data on the surface.
+;;  Externally, a stream-creation function takes
+;;  just a closure --- not a function and data.
+(define _cairo_write_func_t 
+  (_fun #:atomic? #t _pointer _pointer _uint -> _int))
+(define _stream-surface-proc 
+  (_fun _cairo_write_func_t _pointer _double* _double* -> _cairo_surface_t))
+(define cell-key (malloc 1 'raw))
+(define stream-surface-allocator 
+  (lambda (p)
+    ((allocator cairo_surface_destroy)
+     (lambda (proc w h)
+       (let* ([new-proc (lambda (null bytes len)
+                          (proc bytes len))]
+              [s (p new-proc #f w h)]
+              [b (malloc-immobile-cell new-proc)])
+         (cairo_surface_set_user_data s cell-key b free-immobile-cell)
+         s)))))
+(define-cairo cairo_ps_surface_create_for_stream
+  _stream-surface-proc
+  #:wrap stream-surface-allocator)
 (define-cairo cairo_pdf_surface_create_for_stream 
-  ;; As above:
-  (_fun  _fpointer _pointer _double* _double* -> _cairo_surface_t)
-  #:wrap (allocator cairo_surface_destroy))
+  _stream-surface-proc
+  #:wrap stream-surface-allocator)
 (define-cairo cairo_svg_surface_create_for_stream 
-  ;; As above:
-  (_fun  _fpointer _pointer _double* _double* -> _cairo_surface_t)
-  #:wrap (allocator cairo_surface_destroy))
-(define/provide _cairo_write_func_t (_fun _pointer _pointer _uint -> _int))
+  _stream-surface-proc
+  #:wrap stream-surface-allocator)
+
+(define-cairo cairo_surface_set_user_data 
+  (_fun _cairo_surface_t _pointer _pointer (_fun #:atomic? #t _pointer -> _void)
+        -> _int))
+
 (define-cairo cairo_ps_surface_set_eps (_fun _cairo_surface_t _bool -> _void)
   #:fail (lambda ()
 	   ;; cairo_ps_surface_set_eps is in version 1.6 and later;
diff --git a/collects/scribblings/draw/post-script-dc-class.scrbl b/collects/scribblings/draw/post-script-dc-class.scrbl
index 0bc4a360f5..0b82893855 100644
--- a/collects/scribblings/draw/post-script-dc-class.scrbl
+++ b/collects/scribblings/draw/post-script-dc-class.scrbl
@@ -57,7 +57,12 @@ If @scheme[use-paper-bbox] is @scheme[#f], then the PostScript
 When @racket[output] is not @racket[#f], then file-mode output is
  written to @racket[output]. If @racket[output] is @racket[#f], then
  the destination is determined via @racket[current-ps-setup] or by
- prompting the user for a pathname.
+ prompting the user for a pathname. When @racket[output] is a port,
+ then data is written to @racket[port] by a thread that is created
+ with the @racket[post-script-dc%] instance; in case that writing
+ thread's custodian is shut down, calling @method[dc<%> end-doc]
+ resumes the port-writing thread with @racket[thread-resume]
+ and @racket[(current-thread)] as the second argument.
 
 See also @scheme[ps-setup%] and @scheme[current-ps-setup]. The
 settings for a particular @scheme[post-script-dc%] object are fixed to