.

original commit: 853345495ca3f11b4d5d257d693e2c50d1bfb939

collects/mred/mred-sig.ss

@@ -122,7 +122,9 @@
      menu-item<%>
      message%
      message-box
+     message+check-box
      message-box/custom
+     message+check-box/custom
      mouse-event%
      ;; mred@
      mult-color<%>

collects/mred/mred.ss

@@ -6123,23 +6123,25 @@
     (regexp-replace* #rx"&" s "\\&\\&")))
 
 
-(define message-box/custom
+(define do-message-box/custom
-  (opt-lambda (title message 
+  (lambda (who title message
-		     button1
+	       button1 button2 button3
-		     button2
+	       parent style close-result
-		     button3
+	       check? two-results? check-message)
-		     [parent #f]
+    (check-label-string who title)
-		     [style '(no-default)]
+    (check-string/false who message)
-		     [close-result #f])
+    (when check?
-    (check-label-string 'message-box/custom title)
+      (check-label-string who check-message))
-    (check-string/false 'message-box/custom message)
+    (check-label-string-or-bitmap/false who button1)
-    (check-label-string-or-bitmap/false 'message-box/custom button1)
+    (check-label-string-or-bitmap/false who button2)
-    (check-label-string-or-bitmap/false 'message-box/custom button2)
+    (check-label-string-or-bitmap/false who button3)
-    (check-label-string-or-bitmap/false 'message-box/custom button3)
+    (check-top-level-parent/false who parent)
-    (check-top-level-parent/false 'message-box/custom parent)
+    (check-style who 
-    (check-style 'message-box/custom 
 		 '(default=1 default=2 default=3 no-default) 
-		 '(disallow-close number-order caution stop)
+		 (let ([l '(disallow-close number-order caution stop)])
+		   (if check?
+		       (cons 'checked l)
+		       l))
 		 style)
 
     (let* ([strings (let loop ([s message])
@@ -6248,6 +6250,15 @@
 		      (send c show #f)
 		      (send msg-pnl delete-child c)
 		      (loop #t)))))))
+	(let ([check (and check?
+			  (let ([p (new horizontal-pane% [parent btn-pnl]
+					[stretchable-height #f]
+					[alignment '(left center)])])
+			    (new check-box% 
+				 [label check-message]
+				 [parent p]
+				 [callback void]
+				 [value (memq 'checked style)])))])
 	  (let* ([p (make-object horizontal-pane% btn-pnl)]
 		 [mk-button (lambda (title v default?) 
 			      (let ([b (make-object button% title p (lambda (b e) (set! result v) (send f show #f))
@@ -6278,17 +6289,37 @@
 		(mk-1)])))
 	  (send f center)
 	  (send f show #t)
-	result))))
+	  (if two-results?
+	      (values result (and check? (send check get-value)))
+	      result))))))
 
-(define message-box
+(define message-box/custom
-  (case-lambda
+  (opt-lambda (title message 
-   [(title message) (message-box title message #f '(ok))]
+		     button1
-   [(title message parent) (message-box title message parent '(ok))]
+		     button2
-   [(title message parent style)
+		     button3
-    (check-label-string 'message-box title)
+		     [parent #f]
-    (check-string/false 'message-box message)
+		     [style '(no-default)]
-    (check-top-level-parent/false 'message-box parent)
+		     [close-result #f])
-    (check-style 'message-box '(ok ok-cancel yes-no) '(caution stop) style)
+    (do-message-box/custom 'message-box/custom
+			   title message button1 button2 button3
+			   parent style close-result
+			   #f #f #f)))
+
+(define do-message-box
+  (opt-lambda (who title message parent style check? check-message)
+    (check-label-string who title)
+    (check-string/false who message)
+    (when check?
+      (check-label-string who check-message))
+    (check-top-level-parent/false who parent)
+    (check-style who
+		 '(ok ok-cancel yes-no) 
+		 (let ([l '(caution stop)])
+		   (if check?
+		       (cons 'checked l)
+		       l))
+		 style)
 
     (let-values ([(one two one-v two-v close-val default)
 		  (cond
@@ -6298,10 +6329,15 @@
 		     (values "OK" "Cancel" 'ok 'cancel 2 'default=1)]
 		    [(memq 'yes-no style)
 		     (values "&Yes" "&No" 'yes 'no #f 'no-default)])])
-      (case (message-box/custom title message
+      (let-values ([(result checked?)
+		    (do-message-box/custom who
+					   title message
 					   one two #f
 					   parent
 					   (append
+					    (cond
+					     [(memq 'checked style) '(checked)]
+					     [else null])
 					    (cond
 					     [(memq 'stop style) '(stop)]
 					     [(memq 'caution style) '(caution)]
@@ -6309,9 +6345,37 @@
 					    (if close-val
 						(list default)
 						(list default 'disallow-close)))
-				 close-val)
+					   close-val
+					   check? #t check-message)])
+	(let ([result (case result
 			[(1) one-v]
-	[(2) two-v]))]))
+			[(2) two-v])])
+	  (if check?
+	      (values result checked?)
+	      result))))))
+
+(define message-box
+  (opt-lambda (title message [parent #f] [style '(ok)])
+    (do-message-box 'message-box title message parent style #f #f)))
+
+(define message+check-box/custom
+  (opt-lambda (title message 
+		     checkbox-message
+		     button1
+		     button2
+		     button3
+		     [parent #f]
+		     [style '(no-default)]
+		     [close-result #f])
+    (do-message-box/custom 'message+check-box/custom
+			   title message button1 button2 button3
+			   parent style close-result
+			   #t #t checkbox-message)))
+
+(define message+check-box
+  (opt-lambda (title message check-message [parent #f] [style '(ok)])
+    (do-message-box 'message-box title message parent style #t check-message)))
+
 
 (define (number->string* n)
   (let ([s (number->string n)])
@@ -7952,7 +8016,9 @@
 	pasteboard%
 	graphical-read-eval-print-loop
 	message-box
+	message+check-box
 	message-box/custom
+	message+check-box/custom
 	get-file
 	get-file-list
 	put-file