restore doc & page checking for `post-script-dc%' et al.

and also fix up wiring of `printer-dc%' in `editor<%>' so
 that `is-a?' tests works as expected

collects/mred/private/filedialog.rkt

@@ -4,7 +4,8 @@
 	   mzlib/list
 	   (prefix wx: "kernel.ss")
 	   (prefix wx: racket/snip)
-	   (prefix wx: "wxme/cycle.ss")
+	   (rename "wxme/cycle.ss" wx:set-editor-get-file! set-editor-get-file!)
+	   (rename "wxme/cycle.ss" wx:set-editor-put-file! set-editor-put-file!)
 	   "lock.ss"
 	   "wx.ss"
 	   "cycle.ss"

collects/mred/private/gdi.rkt

@@ -2,7 +2,9 @@
   (require mzlib/class
 	   mzlib/class100
            mzlib/list
+           racket/draw/private/page-dc
 	   (prefix wx: "kernel.ss")
+           (rename "wxme/cycle.ss" wx:set-printer-dc%! set-printer-dc%!)
 	   "lock.ss"
 	   "check.ss"
 	   "wx.ss"
@@ -46,123 +48,24 @@
       (check-instance 'unregister-collecting-blit canvas% 'canvas% #f canvas)
       (wx:unregister-collecting-blit (mred->wx canvas))))
 
-  (define-syntax check-page-active
-    (syntax-rules ()
-      [(_ check-page-status (id . args) ...) (begin (check-one-page-active check-page-status id args) ...)]))
-  (define-syntax check-one-page-active
-    (syntax-rules ()
-      [(_ check-page-status id simple ... (arg ... [opt ...]))
-       (check-one-page-active 
-        check-page-status id 
-        simple ...
-        (arg ...)
-        (arg ... opt ...))]
-      [(_ check-page-status id (arg ...) ...)
-       (define/override id
-         (case-lambda
-          [(arg ...) (check-page-status 'id) (super id arg ...)]
-          ...))]))
-
-  (define-local-member-name multiple-pages-ok?)
-
-  (define (doc+page-check-mixin % class-name)
-    (class %
-      (define status #f)
-      (define did-one-page? #f)
-
-      (define/public (multiple-pages-ok?) #t)
-
-      (define/override (start-doc s)
-        (when status
-          (raise-mismatch-error (who->name (list 'method class-name 'start-doc))
-                                (case status
-                                  [(done)
-                                   "document has already been ended: "]
-                                  [else
-                                   "document has already been started: "])
-                                this))
-        (set! status 'doc)
-        (super start-doc s))
-
-      (define/override (end-doc)
-        (unless (eq? status 'doc)
-          (raise-mismatch-error (who->name (list 'method class-name 'end-doc))
-                                (case status
-                                  [(page)
-                                   "current page has not been ended: "]
-                                  [(done)
-                                   "document is already ended: "]
-                                  [(#f)
-                                   "document is not started: "])
-                                this))
-        (set! status 'done)
-        (super end-doc))
-
-      (define/override (start-page)
-        (unless (eq? status 'doc)
-          (raise-mismatch-error (who->name (list 'method class-name 'start-page))
-                                (if (eq? status 'page)
-                                    "current page has not been ended: "
-                                    "document is not started (use the `start-doc' method): ")
-                                this))
-        (when did-one-page?
-          (unless (multiple-pages-ok?)
-            (raise-mismatch-error (who->name (list 'method class-name 'start-page))
-                                  "cannot create multiple pages for EPS output: "
-                                  this)))
-        (set! status 'page)
-        (set! did-one-page? #t)
-        (super start-page))
-
-      (define/override (end-page)
-        (unless (eq? status 'page)
-          (raise-mismatch-error (who->name (list 'method class-name 'end-page))
-                                "no page is currently started: "
-                                this))
-        (set! status 'doc)
-        (super end-page))
-
-      (define/private (check-page-status method-name)
-        (unless (eq? status 'page)
-          (raise-mismatch-error (who->name (list 'method class-name method-name))
-                                "no page is currently started (use `start-doc' and `start-page' before drawing): "
-                                this)))
-
-      (check-page-active
-       check-page-status 
-       (draw-bitmap source dest-x dest-y [style [color [mask]]])
-       (draw-bitmap-section source dest-x dest-y src-x src-y src-width src-height [style [color [mask]]])
-       (set-text-foreground c)
-       (set-text-background c)
-       (set-brush b/c [style])
-       (set-pen p/c [width style])
-       (set-font f)
-       (set-background c)
-       (set-clipping-region r)
-       (set-clipping-rect x y w h)
-       (draw-polygon pts [x [y [fill]]])
-       (draw-lines pts [x [y]])
-       (draw-path path [x [y [fill]]])
-       (draw-ellipse x y w h)
-       (draw-arc x y w h s e)
-       (draw-text txt x y [combine? [offset [angle]]])
-       (draw-spline x1 y1 x2 y2 x3 y3)
-       (draw-rounded-rectangle x y w h [r])
-       (draw-rectangle x y w h)
-       (draw-point x y)
-       (draw-line x1 y1 x2 y2)
-       (clear))
-
-      (super-new)))
-
   (define printer-dc%
-    (class100 (doc+page-check-mixin wx:printer-dc% 'printer-dc%) ([parent #f])
+    (class (doc+page-check-mixin (class wx:printer-dc% 
-      (sequence
+                                   (define/public (multiple-pages-ok?) #t)
-	(check-top-level-parent/false '(constructor printer-dc) parent)
+                                   (super-new))
+                                 'printer-dc%) 
+      (init [parent #f])
+
+      (let ([prim? (or (parent . is-a? . wx:frame%)
+                       (parent . is-a? . wx:dialog%))])
+        (unless prim?
+          (check-top-level-parent/false '(constructor printer-dc) parent))
         (as-entry
          (lambda ()
-	   (let ([p (and parent (mred->wx parent))])
+           (let ([p (if prim?
-	     (as-exit (lambda () (super-init p)))))))))
+                        parent
+                        (and parent (mred->wx parent)))])
+             (as-exit (lambda () (super-new [parent p])))))))))
+  (wx:set-printer-dc%! printer-dc%)
 
   (define get-window-text-extent
     (case-lambda

collects/mred/private/mrpopup.rkt

@@ -3,7 +3,7 @@
 	   mzlib/class100
 	   mzlib/list
 	   (prefix wx: "kernel.ss")
-           (prefix wx: "wxme/cycle.ss")
+           (rename "wxme/cycle.ss" wx:set-popup-menu%! set-popup-menu%!)
 	   "lock.ss"
 	   "const.ss"
 	   "helper.ss"

collects/mred/private/snipfile.rkt

@@ -4,7 +4,6 @@
 	   syntax/moddep
            (prefix-in wx: "kernel.ss")
 	   (prefix-in wx: racket/snip)
-	   (prefix-in wx: "wxme/cycle.ss")
 	   "check.ss"
 	   "editor.ss")
 		

collects/mred/private/wx/cocoa/platform.rkt

@@ -67,7 +67,6 @@
    get-control-font-size
    get-control-font-size-in-pixels?
    get-double-click-time
-   run-printout
    file-creator-and-type
    location->window
    shortcut-visible-in-label?

collects/mred/private/wx/cocoa/procs.rkt

@@ -14,7 +14,6 @@
          "dc.rkt"
          "bitmap.rkt"
          "printer-dc.rkt"
-         "../common/printer.rkt"
          "menu-bar.rkt"
          "agl.rkt"
          "sound.rkt"
@@ -35,7 +34,6 @@
   register-collecting-blit
   unregister-collecting-blit
   shortcut-visible-in-label?
-  run-printout
   get-double-click-time
   get-control-font-face
   get-control-font-size
@@ -79,8 +77,6 @@
   (send canvas unregister-collecting-blits))
 (define (shortcut-visible-in-label? [x #f]) #f)
 
-(define run-printout (make-run-printout printer-dc%))
-
 (define (get-double-click-time)
   500)
 (define (get-control-font-face) "Lucida Grande")

collects/mred/private/wx/common/printer.rkt

@@ -1,25 +0,0 @@
-#lang racket/base
-(require racket/class)
-
-(provide (protect-out make-run-printout))
-
-(define ((make-run-printout printer-dc%)
-         parent
-         interactive? ; currently ignored
-         fit-to-page? ; ignored
-         begin-doc-proc
-         has-page?-proc
-         print-page-proc
-         end-doc-proc)
-  (let ([dc (make-object printer-dc% parent)])
-    (send dc start-doc "printing")
-    (begin-doc-proc dc)
-    (let loop ([i 1])
-      (when (has-page?-proc dc i)
-        (begin
-          (send dc start-page)
-          (print-page-proc dc i)
-          (send dc end-page)
-          (loop (add1 i)))))
-    (end-doc-proc)
-    (send dc end-doc)))

collects/mred/private/wx/gtk/platform.rkt

@@ -68,7 +68,6 @@
    get-control-font-size
    get-control-font-size-in-pixels?
    get-double-click-time
-   run-printout
    file-creator-and-type
    location->window
    shortcut-visible-in-label?

collects/mred/private/wx/gtk/procs.rkt

@@ -16,7 +16,6 @@
          "queue.rkt"
          "printer-dc.rkt"
          "gl-context.rkt"
-         "../common/printer.rkt"
          "../common/default-procs.rkt"
          "../common/handlers.rkt")
 
@@ -30,7 +29,6 @@
   register-collecting-blit
   unregister-collecting-blit
   shortcut-visible-in-label?
-  run-printout
   get-double-click-time
   get-control-font-face
   get-control-font-size
@@ -82,8 +80,6 @@
   (send canvas unregister-collecting-blits))
 (define (shortcut-visible-in-label? [mbar? #f]) #t)
 
-(define run-printout (make-run-printout printer-dc%))
-
 (define _GtkSettings (_cpointer 'GtkSettings))
 (define-gtk gtk_settings_get_default (_fun -> _GtkSettings))
 (define-gobj g_object_get/int (_fun _GtkSettings _string (r : (_ptr o _int)) (_pointer = #f) 

collects/mred/private/wx/platform.rkt

@@ -54,7 +54,6 @@
                 get-control-font-size
                 get-control-font-size-in-pixels?
                 get-double-click-time
-                run-printout
                 file-creator-and-type
                 location->window
                 shortcut-visible-in-label?

collects/mred/private/wx/win32/platform.rkt

@@ -68,7 +68,6 @@
    get-control-font-size
    get-control-font-size-in-pixels?
    get-double-click-time
-   run-printout
    file-creator-and-type
    location->window
    shortcut-visible-in-label?

collects/mred/private/wx/win32/procs.rkt

@@ -11,7 +11,6 @@
          "window.rkt"
          "dc.rkt"
          "printer-dc.rkt"
-         "../common/printer.rkt"
          (except-in "../common/default-procs.rkt"
                     get-panel-background)
          "filedialog.rkt"
@@ -29,7 +28,6 @@
   register-collecting-blit
   unregister-collecting-blit
   shortcut-visible-in-label?
-  run-printout
   get-double-click-time
   get-control-font-face
   get-control-font-size
@@ -80,8 +78,6 @@
   (send canvas unregister-collecting-blits))
 (define (shortcut-visible-in-label? [? #f]) #t)
 
-(define run-printout (make-run-printout printer-dc%))
-
 (define (get-double-click-time) 500)
 (define (get-control-font-face) (get-theme-font-face))
 (define (get-control-font-size) (get-theme-font-size))

collects/mred/private/wxme/cycle.rkt

@@ -24,4 +24,5 @@
 
 (decl popup-menu% set-popup-menu%!)
 
+(decl printer-dc% set-printer-dc%!)
 

collects/mred/private/wxme/editor.rkt

@@ -14,6 +14,7 @@
          "keymap.ss"
          "editor-data.rkt"
          (only-in "cycle.ss" 
+                  printer-dc%
                   text%
                   pasteboard%
                   editor-snip%
@@ -736,6 +737,27 @@
   (define/public (do-end-print) (void))
   (define/public (do-has-print-page?) (void))
 
+  (define/private (run-printout
+                   parent
+                   interactive? ; currently ignored
+                   fit-to-page? ; ignored
+                   begin-doc-proc
+                   has-page?-proc
+                   print-page-proc
+                   end-doc-proc)
+    (let ([dc (make-object printer-dc% parent)])
+      (send dc start-doc "printing")
+      (begin-doc-proc dc)
+      (let loop ([i 1])
+        (when (has-page?-proc dc i)
+          (begin
+            (send dc start-page)
+            (print-page-proc dc i)
+            (send dc end-page)
+            (loop (add1 i)))))
+      (end-doc-proc)
+      (send dc end-doc)))
+
   (def/public (print [bool? [interactive? #t]]
                      [bool? [fit-to-page? #t]]
                      [(symbol-in standard postscript) [output-mode 'standard]]

collects/mred/private/wxme/pasteboard.rkt

@@ -13,7 +13,9 @@
          racket/snip/private/snip-flags
          "standard-snip-admin.rkt"
          "keymap.ss"
-         (only-in "cycle.ss" set-pasteboard%!)
+         (only-in "cycle.ss" 
+                  printer-dc%
+                  set-pasteboard%!)
          "wordbreak.ss"
          "stream.ss"
          "wx.ss")

collects/mred/private/wxme/text.rkt

@@ -15,7 +15,9 @@
          racket/snip/private/snip-flags
          "standard-snip-admin.rkt"
          "keymap.ss"
-         (only-in "cycle.ss" set-text%!)
+         (only-in "cycle.ss" 
+                  printer-dc%
+                  set-text%!)
          "wordbreak.ss"
          "stream.ss"
          "wx.ss")

collects/mred/private/wxme/wx.rkt

@@ -27,7 +27,6 @@
          bitmap%
          dc<%>
          post-script-dc%
-         printer-dc%
          current-eventspace
          clipboard-client%
          clipboard<%>
@@ -37,7 +36,6 @@
          begin-busy-cursor
          end-busy-cursor
          hide-cursor
-         run-printout
          current-ps-setup
          get-highlight-background-color
          get-highlight-text-color)

collects/racket/draw/private/page-dc.rkt

@@ -0,0 +1,109 @@
+#lang racket/base
+(require racket/class
+         "syntax.rkt")
+
+(provide doc+page-check-mixin
+         multiple-pages-ok?)
+
+(define-local-member-name multiple-pages-ok?)
+
+(define-syntax check-page-active
+  (syntax-rules ()
+    [(_ check-page-status (id . args) ...) (begin (check-one-page-active check-page-status id args) ...)]))
+
+(define-syntax check-one-page-active
+  (syntax-rules ()
+    [(_ check-page-status id simple ... (arg ... [opt ...]))
+     (check-one-page-active 
+      check-page-status id 
+      simple ...
+      (arg ...)
+      (arg ... opt ...))]
+    [(_ check-page-status id (arg ...) ...)
+     (define/override id
+       (case-lambda
+        [(arg ...) (check-page-status 'id) (super id arg ...)]
+        ...))]))
+
+(define (doc+page-check-mixin % class-name)
+  (class %
+    (inherit multiple-pages-ok?)
+
+    (define status #f)
+    (define did-one-page? #f)
+
+    (define/override (start-doc s)
+      (when status
+        (raise-mismatch-error (method-name class-name 'start-doc)
+                              (case status
+                                [(done)
+                                 "document has already been ended: "]
+                                [else
+                                 "document has already been started: "])
+                              this))
+      (set! status 'doc)
+      (super start-doc s))
+
+    (define/override (end-doc)
+      (unless (eq? status 'doc)
+        (raise-mismatch-error (method-name class-name 'end-doc)
+                              (case status
+                                [(page)
+                                 "current page has not been ended: "]
+                                [(done)
+                                 "document is already ended: "]
+                                [(#f)
+                                 "document is not started: "])
+                              this))
+      (set! status 'done)
+      (super end-doc))
+
+    (define/override (start-page)
+      (unless (eq? status 'doc)
+        (raise-mismatch-error (method-name class-name 'start-page)
+                              (if (eq? status 'page)
+                                  "current page has not been ended: "
+                                  "document is not started (use the `start-doc' method): ")
+                              this))
+      (when did-one-page?
+        (unless (multiple-pages-ok?)
+          (raise-mismatch-error (method-name class-name 'start-page)
+                                "cannot create multiple pages for encapsulated output: "
+                                this)))
+      (set! status 'page)
+      (set! did-one-page? #t)
+      (super start-page))
+
+    (define/override (end-page)
+      (unless (eq? status 'page)
+        (raise-mismatch-error (method-name class-name 'end-page)
+                              "no page is currently started: "
+                              this))
+      (set! status 'doc)
+      (super end-page))
+
+    (define/private (check-page-status the-method-name)
+      (unless (eq? status 'page)
+        (raise-mismatch-error (method-name class-name the-method-name)
+                              "no page is currently started (use `start-doc' and `start-page' before drawing): "
+                              this)))
+
+    (check-page-active
+     check-page-status 
+     (draw-bitmap source dest-x dest-y [style [color [mask]]])
+     (draw-bitmap-section source dest-x dest-y src-x src-y src-width src-height [style [color [mask]]])
+     (draw-polygon pts [x [y [fill]]])
+     (draw-lines pts [x [y]])
+     (draw-path path [x [y [fill]]])
+     (draw-ellipse x y w h)
+     (draw-arc x y w h s e)
+     (draw-text txt x y [combine? [offset [angle]]])
+     (draw-spline x1 y1 x2 y2 x3 y3)
+     (draw-rounded-rectangle x y w h [r])
+     (draw-rectangle x y w h)
+     (draw-point x y)
+     (draw-line x1 y1 x2 y2)
+     (clear)
+     (erase))
+
+    (super-new)))

collects/racket/draw/private/post-script-dc.rkt

@@ -11,6 +11,7 @@
          "font.ss"
          "local.ss"
          "ps-setup.ss"
+         "page-dc.rkt"
          "write-bytes.rkt")
 
 (provide post-script-dc%
@@ -176,9 +177,14 @@
     (define/override (can-mask-bitmap?)
       #f)
 
+    (define is-eps? (and as-eps #t))
+    (define/public (multiple-pages-ok?) (not is-eps?))
+
     (super-new)))
 
-(define post-script-dc% (class (dc-mixin (make-dc-backend #f))
+(define post-script-dc% (class (doc+page-check-mixin (dc-mixin (make-dc-backend #f))
+                                                     'post-script-dc%)
                           (super-new)))
-(define pdf-dc% (class (dc-mixin (make-dc-backend #t))
+(define pdf-dc% (class (doc+page-check-mixin (dc-mixin (make-dc-backend #t))
+                                             'pdf-dc%)
                   (super-new)))

collects/racket/draw/private/svg-dc.rkt

@@ -10,6 +10,7 @@
          "font.ss"
          "local.ss"
          "ps-setup.ss"
+         "page-dc.rkt"
          "write-bytes.rkt")
 
 (provide svg-dc%)
@@ -80,7 +81,10 @@
     (define/override (can-combine-text? sz)
       #t)
 
+    (define/public (multiple-pages-ok?) #t)
+
     (super-new)))
 
-(define svg-dc% (class (dc-mixin dc-backend%)
+(define svg-dc% (class (doc+page-check-mixin (dc-mixin dc-backend%)
+                                             'svg-dc%)
                   (super-new)))

collects/scribblings/draw/dc-intf.scrbl

@@ -443,7 +443,7 @@ Ends a document, relevant only when drawing to a printer, PostScript,
  PDF, or SVG device.
 
 For relevant devices, an exception is raised if
-@scheme[end-doc] is called when the document is not started with
+@method[dc<%> end-doc] is called when the document is not started with
 @method[dc<%> start-doc], when a page is currently started by
 @method[dc<%> start-page] and not ended with @method[dc<%> end-page],
 or when the document has been ended already.
@@ -458,7 +458,7 @@ Ends a single page, relevant only when drawing to a printer,
  PostScript, PDF, or SVG device.
 
 For relevant devices, an exception is raised if
-@scheme[end-page] is called when a page is not currently started by
+@method[dc<%> end-page] is called when a page is not currently started by
 @method[dc<%> start-page].}
 
 
@@ -1071,7 +1071,7 @@ Starts a document, relevant only when drawing to a printer,
  @method[dc<%> end-doc] is called.
 
 For relevant devices, an exception is raised if
- @scheme[start-doc] has been called already (even if @method[dc<%>
+ @method[dc<%> start-doc] has been called already (even if @method[dc<%>
  end-doc] has been called as well). Furthermore, drawing methods raise
  an exception if not called while a page is active as determined by
  @method[dc<%> start-doc] and @method[dc<%> start-page].
@@ -1085,7 +1085,7 @@ Starts a page, relevant only when drawing to a printer, PostScript,
  SVG, or PDF device.
 
 Relevant devices, an exception is raised if
- @scheme[start-page] is called when a page is already started, or when
+ @method[dc<%> start-page] is called when a page is already started, or when
  @method[dc<%> start-doc] has not been called, or when @method[dc<%>
  end-doc] has been called already. In addition, in the case of
  PostScript output, Encapsulated PostScript (EPS) cannot contain