.

original commit: f91b745769e8b6ec4038d442604e2b392b03dfa3

collects/mred/edit.ss

@@ -4,7 +4,8 @@
 
 (module edit mzscheme
   (require (lib "class.ss")
-	   (lib "mred.ss" "mred"))
+	   (lib "mred.ss" "mred")
+	   (lib "etc.ss"))
 
   (provide new-text-frame
 	   new-pasteboard-frame
@@ -13,12 +14,12 @@
   (define (new-text-frame file) (new-frame text% file))
   (define (new-pasteboard-frame file) (new-frame pasteboard% file))
 
-  (define (new-frame editor% file)
+  (define new-frame
+    (opt-lambda (editor% file [editor-canvas% editor-canvas%])
       (define f (make-object (class frame%
 			       (inherit modified)
-			     (define/override (can-close?)
+			       (define/augment (can-close?)
-			       (and (super can-close?)
+				 (and (or (not (modified))
-				    (or (not (modified))
 					  (let ([r (message-box/custom
 						    "Editor Modified"
 						    "The editor has been modified. Really close it?"
@@ -29,7 +30,8 @@
 						    '(default=2 disallow-close))])
 					    (or (and (= r 3)
 						     (send e save-file))
-					      (= r 1))))))
+						(= r 1))))
+				      (inner #t can-close?)))
 			       (super-new))
 			     "MrEdIt" #f 620 450))
       (define c (make-object editor-canvas% f))
@@ -152,4 +154,4 @@
 	    (send e load-file file)))
       
       (send f show #t)
-    f))
+      f)))

collects/mred/mred.ss

@@ -4831,7 +4831,8 @@
   (interface (subwindow<%>)
     min-client-width min-client-height
     on-char on-event on-paint on-scroll on-tab-in
-    warp-pointer get-dc))
+    warp-pointer get-dc
+    set-canvas-background get-canvas-background))
 
 (define-keywords canvas%-keywords
   window%-keywords
@@ -4852,7 +4853,24 @@
 
       [warp-pointer (entry-point (lambda (x y) (send wx warp-pointer x y)))]
 
-      [get-dc (entry-point (lambda () (send wx get-dc)))])
+      [get-dc (entry-point (lambda () (send wx get-dc)))]
+
+      [set-canvas-background
+       (entry-point
+	(lambda (c)
+	  (unless (c . is-a? . wx:color%)
+	    (raise-type-error (who->name '(method canvas<%> set-canvas-background))
+			      "color% object"
+			      c))
+	  (unless (send wx get-canvas-background)
+	    (raise-mismatch-error (who->name '(method canvas<%> set-canvas-background))
+				  "cannot set a transparent canvas's background color: "
+				  c))
+	  (send wx set-canvas-background c)))]
+      [get-canvas-background
+       (entry-point
+	(lambda ()
+	  (send wx get-canvas-background)))])
     (private-field
       [wx #f])
     (sequence
@@ -4977,7 +4995,7 @@
       (let ([cwho '(constructor editor-canvas)])
 	(check-container-parent cwho parent)
 	(check-instance cwho internal-editor<%> "text% or pasteboard%" #t editor)
-	(check-style cwho #f '(hide-vscroll hide-hscroll no-vscroll no-hscroll deleted control-border) style)
+	(check-style cwho #f '(hide-vscroll hide-hscroll no-vscroll no-hscroll deleted control-border transparent) style)
 	(check-gauge-integer cwho scrolls-per-page)
 	(check-label-string/false cwho label)
 	(unless (eq? wheel-step no-val)

collects/mred/private/kernel.ss

@@ -342,6 +342,8 @@
     on-size
     on-set-focus
     on-kill-focus
+    get-canvas-background
+    set-canvas-background
     set-background-to-gray
     on-scroll
     set-scroll-page
@@ -647,6 +649,8 @@
     on-kill-focus
     popup-for-editor
     call-as-primary-owner
+    get-canvas-background
+    set-canvas-background
     set-y-margin
     set-x-margin
     get-y-margin