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

original commit: a9dd80110a4aa750b60de71bc9432e51f070c6b1

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))
-	(as-entry
+                                 'printer-dc%) 
-	 (lambda ()
+      (init [parent #f])
-	   (let ([p (and parent (mred->wx parent))])
+
-	     (as-exit (lambda () (super-init p)))))))))
+      (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 (if prim?
+                        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/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)