From d73e8448d5cdf14c5eb6f7b7c227adad28f1b333 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sun, 8 Apr 2007 23:30:58 +0000
Subject: [PATCH] misc improvements to the white on black view in drscheme
 (also added explicit buttons that switch to a default set of colors and also
 flips a preferences flag for more coarse grained control)

svn: r5892

original commit: d688a1f9e3d6cf001852404c7fafc55ffaace710
---
 collects/framework/framework.ss           |  48 +-
 collects/framework/gui-utils.ss           |  39 +-
 collects/framework/preferences.ss         |  11 +-
 collects/framework/private/color-prefs.ss | 102 +++-
 collects/framework/private/frame.ss       |  13 +-
 collects/framework/private/main.ss        | 563 +++++++++++-----------
 collects/framework/private/scheme.ss      |  46 +-
 collects/framework/private/sig.ss         |   4 +-
 8 files changed, 497 insertions(+), 329 deletions(-)

diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss
index 52ec47a1..bc9d7af9 100644
--- a/collects/framework/framework.ss
+++ b/collects/framework/framework.ss
@@ -1245,6 +1245,22 @@
      "@flink scheme:short-sym->pref-name"
      "and"
      "@flink scheme:short-sym->style-name %"
+     "."
+     ""
+     "See also"
+     "@flink scheme:get-white-on-black-color-prefs-table %"
+     ".")
+    
+    (scheme:get-white-on-black-color-prefs-table
+     (-> (listof (list/c symbol? (is-a?/c color%))))
+     ()
+     "Returns a table mapping from symbols (naming the categories that"
+     "the online colorer uses for Scheme mode coloring) to their"
+     "colors when the user chooses the white-on-black mode in the"
+     "preferences dialog."
+     ""
+     "See also"
+     "@flink scheme:get-color-prefs-table %"
      ".")
     
     (scheme:short-sym->pref-name
@@ -1364,9 +1380,29 @@
      (xyz)
      "Extracts the z component of \\var{xyz}.")
     
+    (color-prefs:set-default/color-scheme
+     (-> symbol?
+         (or/c (is-a?/c color%) string?) 
+         (or/c (is-a?/c color%) string?)
+         void?)
+     (pref-sym black-on-white-color white-on-black-color)
+     "Registers a preference whose value will be updated"
+     "when the user clicks on one of the color scheme default"
+     "settings in the preferences dialog."
+     ""
+     "Also calls "
+     "@flink preferences:set-default"
+     "and"
+     "@flink preferences:set-un/marshall"
+     "with appropriate arguments to register the preference.")
+    
     (color-prefs:register-color-pref 
-     (symbol? string? (or/c (is-a?/c color%) (is-a?/c style-delta%)) . -> . void?)
-     (pref-name style-name color/sd)
+     (opt->
+      (symbol? string? (or/c (is-a?/c color%) (is-a?/c style-delta%)))
+      ((or/c string? (is-a?/c color%) false/c))
+      void?)
+     ((pref-name style-name color/sd)
+      ((white-on-black-color #f)))
      "This function registers a color preference and initializes the"
      "style list returned from"
      "@flink editor:get-standard-style-list %"
@@ -1387,7 +1423,13 @@
      "Finally, it adds calls"
      "@flink preferences:add-callback "
      "to set a callback for \\var{pref-name} that"
-     "updates the style list when the preference changes.")
+     "updates the style list when the preference changes."
+     ""
+     "If \\var{white-on-black-color} is not \\scheme|#f|, then the color of the"
+     "\\var{color/sd} argument is used in combination with \\var{white-on-black-color}"
+     "to register this preference with"
+     "@flink color-prefs:set-default/color-scheme %"
+     ".")
       
     (color-prefs:add-background-preferences-panel
      (-> void?)
diff --git a/collects/framework/gui-utils.ss b/collects/framework/gui-utils.ss
index 703c09eb..dd7a4076 100644
--- a/collects/framework/gui-utils.ss
+++ b/collects/framework/gui-utils.ss
@@ -136,11 +136,24 @@
 
   
   (define clickback-delta (make-object style-delta% 'change-underline #t))
+  (define white-on-black-clickback-delta (make-object style-delta% 'change-underline #t))
   (send clickback-delta set-delta-foreground "BLUE")
-  (define (get-clickback-delta) clickback-delta)
+  (send white-on-black-clickback-delta set-delta-foreground "lightblue")
+  (define get-clickback-delta
+    (opt-lambda ([white-on-black? #f])
+      (if white-on-black? 
+          white-on-black-clickback-delta
+          clickback-delta)))
+  
   (define clicked-clickback-delta (make-object style-delta%))
+  (define white-on-black-clicked-clickback-delta (make-object style-delta%))
   (send clicked-clickback-delta set-delta-background "BLACK")
-  (define (get-clicked-clickback-delta) clicked-clickback-delta)
+  (send white-on-black-clicked-clickback-delta set-delta-background "white")
+  (define get-clicked-clickback-delta
+    (opt-lambda ([white-on-black? #f])
+      (if white-on-black? 
+          white-on-black-clicked-clickback-delta
+          clicked-clickback-delta)))
   
   (define next-untitled-name
     (let ([n 1])
@@ -475,27 +488,41 @@
     "caller's responsibility to avoid the dialog if not needed.")
 
    (gui-utils:get-clicked-clickback-delta
-    (-> (is-a?/c style-delta%))
-    ()
+    (opt->
+     ()
+     (boolean?)
+     (is-a?/c style-delta%))
+    (()
+     ((white-on-black? #f)))
     "This delta is designed for use with"
     "@link text set-clickback %"
     ". Use it as one of the \\iscmclass{style-delta} argument to"
     "@link text set-clickback %"
     "."
     ""
+    "If \\var{white-on-black?} is true, the function returns"
+    "a delta suitable for use on a black background."
+    ""
     "See also"
     "@flink gui-utils:get-clickback-delta %"
     ".")
 
    (gui-utils:get-clickback-delta
-    (-> (is-a?/c style-delta%))
-    ()
+    (opt-> 
+     ()
+     (boolean?)
+     (is-a?/c style-delta%))
+    (()
+     ((white-on-black? #f)))
     "This delta is designed for use with"
     "@link text set-clickback %"
     ". Use the result of this function as the style"
     "for the region"
     "text where the clickback is set." 
     ""
+    "If \\var{white-on-black?} is true, the function returns"
+    "a delta suitable for use on a black background."
+    ""
     "See also"
     "@flink gui-utils:get-clicked-clickback-delta %"
     ".")))
diff --git a/collects/framework/preferences.ss b/collects/framework/preferences.ss
index 4af26cbd..4d8cf83c 100644
--- a/collects/framework/preferences.ss
+++ b/collects/framework/preferences.ss
@@ -228,7 +228,9 @@ the state transitions / contracts are:
                            (begin 
                              (v p value)
                              (cons callback (loop (cdr callbacks))))
-                           (loop (cdr callbacks))))]
+                           (begin
+                             (printf "lost a ~s callback\n" p)
+                             (loop (cdr callbacks)))))]
                     [else
                      (cb p value)
                      (cons callback (loop (cdr callbacks)))]))]))])
@@ -383,7 +385,12 @@ the state transitions / contracts are:
     "\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}"
     "if the preference's default has not been set.")
    (preferences:add-callback
-    (opt-> (symbol? (symbol? any/c . -> . any/c))
+    (opt-> (symbol? 
+            
+            ;; important that this arg only has a flat contract
+            ;; so that no wrapper is created, so that
+            ;; the weak box stuff works ...
+            (λ (x) (and (procedure? x) (procedure-arity-includes? x 2))))
            (boolean?)
            (-> void?))
     ((p f)
diff --git a/collects/framework/private/color-prefs.ss b/collects/framework/private/color-prefs.ss
index 3eddbbb6..c40ccabb 100644
--- a/collects/framework/private/color-prefs.ss
+++ b/collects/framework/private/color-prefs.ss
@@ -207,7 +207,20 @@
          (build-text-foreground-selection-panel vp
                                                 'framework:default-text-color
                                                 (editor:get-default-color-style-name)
-                                                (string-constant default-text-color))))))
+                                                (string-constant default-text-color))
+         
+         (let ([hp (new horizontal-panel% 
+                        [parent vp]
+                        [alignment '(center top)])])
+           (new button%
+                [label (string-constant white-on-black-color-scheme)]
+                [parent hp]
+                [callback (λ (x y) (white-on-black))])
+           (new button%
+                [label (string-constant black-on-white-color-scheme)]
+                [parent hp]
+                [callback (λ (x y) (black-on-white))]))))))
+  
   
   (define (build-text-foreground-selection-panel parent pref-sym style-name example-text)
     (define hp (new horizontal-panel% 
@@ -293,17 +306,76 @@
          panel))))
   
   ;; see docs
-  (define (register-color-pref pref-name style-name color/sd)
-    (let ([sd (cond 
-                [(is-a? color/sd style-delta%)
-                 color/sd]
-                [else
-                 (let ([sd (new style-delta%)])
-                   (send sd set-delta-foreground color/sd)
-                   sd)])])
-      (preferences:set-default pref-name sd (λ (x) (is-a? x style-delta%))))
-    (preferences:set-un/marshall pref-name marshall-style unmarshall-style)
-    (preferences:add-callback pref-name
-                              (λ (sym v)
-                                (editor:set-standard-style-list-delta style-name v)))
-    (editor:set-standard-style-list-delta style-name (preferences:get pref-name))))
+  (define register-color-pref
+    (opt-lambda (pref-name style-name color/sd [white-on-black-color #f])
+      (let ([sd (cond 
+                  [(is-a? color/sd style-delta%)
+                   color/sd]
+                  [else
+                   (let ([sd (new style-delta%)])
+                     (send sd set-delta-foreground color/sd)
+                     sd)])])
+        (preferences:set-default pref-name sd (λ (x) (is-a? x style-delta%)))
+        (when white-on-black-color
+          (set! color-scheme-colors
+                (cons (list pref-name
+                            color/sd
+                            (to-color white-on-black-color))
+                      color-scheme-colors)))
+        (preferences:set-un/marshall pref-name marshall-style unmarshall-style)
+        (preferences:add-callback pref-name
+                                  (λ (sym v)
+                                    (editor:set-standard-style-list-delta style-name v)))
+        (editor:set-standard-style-list-delta style-name (preferences:get pref-name)))))
+  
+  (define color-scheme-colors '())
+  
+  (define (set-default/color-scheme pref-sym black-on-white white-on-black)
+    (let ([bw-c (to-color black-on-white)]
+          [wb-c (to-color white-on-black)])
+      (set! color-scheme-colors
+            (cons (list pref-sym 
+                        (to-color black-on-white)
+                        (to-color white-on-black))
+                  color-scheme-colors))
+      
+      (preferences:set-default pref-sym bw-c (λ (x) (is-a? x color%)))
+      (preferences:set-un/marshall 
+       pref-sym
+       (λ (clr) (list (send clr red) (send clr green) (send clr blue)))
+       (λ (lst) (and (pair? lst)
+                     (pair? (cdr lst))
+                     (pair? (cddr lst))
+                     (null? (cdddr lst))
+                     (make-object color% (car lst) (cadr lst) (caddr lst)))))
+      (void)))
+  
+  (define (to-color c)
+    (cond
+      [(is-a? c color%) c]
+      [(is-a? c style-delta%)
+       (send c get-delta-foreground)]
+      [(string? c)
+       (or (send the-color-database find-color c)
+           (error 'register-color-scheme 
+                  "did not find color ~s in the-color-database"
+                  c))]))
+  
+  (define (black-on-white)
+    (preferences:set 'framework:white-on-black? #f)
+    (do-colorization cadr))
+  (define (white-on-black)
+    (preferences:set 'framework:white-on-black? #t)
+    (do-colorization caddr))
+  (define (do-colorization sel)
+    (for-each (λ (l) 
+                (let* ([p (car l)]
+                       [color (sel l)]
+                       [old (preferences:get p)])
+                  (cond
+                    [(is-a? old color%)
+                     (preferences:set p color)]
+                    [(is-a? old style-delta%)
+                     (send old set-delta-foreground color)
+                     (preferences:set p old)])))
+              color-scheme-colors)))
diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss
index 276f57a1..72102434 100644
--- a/collects/framework/private/frame.ss
+++ b/collects/framework/private/frame.ss
@@ -34,7 +34,7 @@
                   [-pasteboard% pasteboard%]
                   [-text% text%]))
 
-  (init-depend mred^ framework:text^)
+  (init-depend mred^ framework:text^ framework:canvas^)
   
       (define (reorder-menus frame)
         (define items (send (send frame get-menu-bar) get-items))
@@ -1414,7 +1414,7 @@
           delegate-moved))
       
       (define delegatee-editor-canvas%
-        (class editor-canvas%
+        (class (canvas:color-mixin canvas:basic%)
           (init-field delegate-frame)
           (inherit get-editor get-dc)
           
@@ -1525,9 +1525,14 @@
               (let ([old-pen (send dc get-pen)]
                     [old-brush (send dc get-brush)])
                 (send dc set-pen
-                      (send the-pen-list find-or-create-pen "light blue" 1 'solid))
+                      (send the-pen-list find-or-create-pen 
+                            (preferences:get 'framework:delegatee-overview-color)
+                            1
+                            'solid))
                 (send dc set-brush
-                      (send the-brush-list find-or-create-brush "light blue" 'solid))
+                      (send the-brush-list find-or-create-brush 
+                            (preferences:get 'framework:delegatee-overview-color)
+                            'solid))
                 (let-values ([(x y w h) (get-rectangle start-para end-para)])
                   (when x
                     (send dc draw-rectangle 
diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss
index abb0da8c..b342c821 100644
--- a/collects/framework/private/main.ss
+++ b/collects/framework/private/main.ss
@@ -15,293 +15,284 @@
   (export framework:main^)
   (init-depend framework:preferences^ framework:exit^ framework:editor^
                framework:color-prefs^ framework:scheme^)
-
+  
   (preferences:low-level-put-preferences preferences:put-preferences/gui)
   
   (application-preferences-handler (λ () (preferences:show-dialog)))
   
-      (preferences:set-default 'framework:square-bracket:cond/offset
-                               '(("case-lambda" 0)
-                                 ("cond" 0)
-                                 ("field" 0)
-                                 ("provide/contract" 0)
-                                 ("new" 1)
-                                 ("case" 1)
-                                 ("syntax-case" 2)
-                                 ("syntax-case*" 3))
-                               (λ (x) (and (list? x) (andmap (λ (x) (and (pair? x)
-                                                                         (string? (car x))
-                                                                         (pair? (cdr x))
-                                                                         (number? (cadr x))
-                                                                         (null? (cddr x))))
-                                                             x))))
-      
-      (preferences:set-default 'framework:square-bracket:letrec
-                               '("let" 
-                                 "let*" "let-values" "let*-values"
-                                 "let-syntax" "let-struct" "let-syntaxes"
-                                 "letrec"
-                                 "letrec-syntaxes" "letrec-syntaxes+values" "letrec-values"
-                                 "parameterize"
-                                 "with-syntax")
-                               (λ (x) (and (list? x) (andmap string? x))))
-      
-      (preferences:set-default 'framework:case-sensitive-search?
-                               #f
-                               boolean?)
-      (preferences:set-default 'framework:basic-canvas-background
-                               (send the-color-database find-color "white")
-                               (λ (x) (is-a? x color%)))
-      (preferences:set-un/marshall 
-       'framework:basic-canvas-background
-       (λ (clr) (list (send clr red) (send clr green) (send clr blue)))
-       (λ (lst) (and (pair? lst)
-                          (pair? (cdr lst))
-                          (pair? (cddr lst))
-                          (null? (cdddr lst))
-                          (make-object color% (car lst) (cadr lst) (caddr lst)))))
-      
-      (preferences:set-default 'framework:special-option-key #f boolean?)
-      (preferences:add-callback 'framework:special-option-key (λ (p v) (special-option-key v)))
-      (special-option-key (preferences:get 'framework:special-option-key))
-      
-      (preferences:set-default 'framework:fraction-snip-style 'mixed (λ (x) (memq x '(mixed improper))))
-      
-      (preferences:set-default 'framework:standard-style-list:font-name
-                               (get-family-builtin-face 'modern)
-                               string?)
-      
-      (preferences:set-default
-       'framework:standard-style-list:font-size
-       (let* ([txt (make-object text%)]
-              [stl (send txt get-style-list)]
-              [bcs (send stl basic-style)])
-         (send bcs get-size))
-       (λ (x) (and (number? x) (exact? x) (integer? x) (positive? x))))
-      
-      (preferences:set-default
-       'framework:standard-style-list:smoothing
-       'default
-       (λ (x) 
-         (memq x '(unsmoothed partly-smoothed smoothed default))))
-      
-      (editor:set-standard-style-list-pref-callbacks)
-      
-      (preferences:set-default 'framework:paren-match-color
-                               (let ([gray-level
-                                      ;; old gray-level 192
-                                      (if (eq? (system-type) 'windows)
-                                          (* 3/4 256)
-                                          (- (* 7/8 256) 1))])
-                                 (make-object color% gray-level gray-level gray-level))
-                               (λ (x) (is-a? x color%)))
-      
-      (preferences:set-un/marshall
-       'framework:paren-match-color
-       (λ (c) (list (send c red) (send c green) (send c blue)))
-       (λ (l) (make-object color% (car l) (cadr l) (caddr l))))
-      
-      (preferences:set-default 'framework:recently-opened-files/pos 
-                               null 
-                               (λ (x) (and (list? x) 
-                                                (andmap
-                                                 (λ (x) 
-                                                   (and (list? x)
-                                                        (= 3 (length x))
-                                                        (path? (car x))
-                                                        (number? (cadr x))
-                                                        (number? (caddr x))))
-                                                 x))))
-      
-      (preferences:set-un/marshall
-       'framework:recently-opened-files/pos
-       (λ (l) (map (λ (ele) (cons (path->bytes (car ele)) (cdr ele))) l))
-       (λ (l) 
-         (let/ec k
-           (unless (list? l)
-             (k '()))
-           (map (λ (x)
-                  (unless (and (list? x)
-                               (= 3 (length x))
-                               (bytes? (car x))
-                               (number? (cadr x))
-                               (number? (caddr x)))
-                    (k '()))
-                  (cons (bytes->path (car x)) (cdr x)))
-                l))))
-      
-      (preferences:set-default 'framework:last-directory 
-                               (find-system-path 'doc-dir) 
-                               (λ (x) (or (not x) path-string?)))
-      
-      (preferences:set-un/marshall 'framework:last-directory 
-                                   (λ (x) (and (path? x) (path->bytes x)))
-                                   (λ (x)
-                                     (and (bytes? x)
-                                          (bytes->path x))))
-
-      (preferences:set-default 'framework:recent-max-count 
-                               50 
-                               (λ (x) (and (number? x)
-                                                (x . > . 0) 
-                                                (integer? x))))
-      (preferences:add-callback
-       'framework:recent-max-count
-       (λ (p v)
-         (handler:size-recently-opened-files v)))
-      
-      (preferences:set-default 'framework:last-url-string "" string?)
-      (preferences:set-default 'framework:recently-opened-sort-by 'age 
-                               (λ (x) (or (eq? x 'age) (eq? x 'name))))
-      (preferences:set-default 'framework:recent-items-window-w 400 number?)
-      (preferences:set-default 'framework:recent-items-window-h 600 number?)
-      (preferences:set-default 'framework:open-here? #f boolean?)
-      (preferences:set-default 'framework:show-delegate? #f boolean?)
-      (preferences:set-default 'framework:search-using-dialog? #t boolean?)
-      (preferences:set-default 'framework:windows-mdi #f boolean?)
-      (preferences:set-default 'framework:menu-bindings #t boolean?)
-      (preferences:set-default 'framework:verify-change-format #f boolean?)
-      (preferences:set-default 'framework:auto-set-wrap? #t boolean?)
-      (preferences:set-default 'framework:display-line-numbers #t boolean?)
-      (preferences:set-default 'framework:show-status-line #t boolean?)
-      (preferences:set-default 'framework:col-offsets #f boolean?)
-      
-      (preferences:set-default
-       'framework:print-output-mode
-       'standard
-       (λ (x) (or (eq? x 'standard) (eq? x 'postscript))))
-      
-      (preferences:set-default 'framework:highlight-parens #t boolean?)
-      (preferences:set-default 'framework:fixup-parens #t boolean?)
-      (preferences:set-default 'framework:fixup-open-parens #t boolean?)
-      (preferences:set-default 'framework:paren-match #t boolean?)
-      (let ([hash-table (make-hash-table)])
-	(for-each (λ (x) 
-                    (hash-table-put! hash-table x 'define))
-                  '())
-	(for-each (λ (x) 
-		    (hash-table-put! hash-table x 'begin))
-		  '(case-lambda
-                     match-lambda match-lambda*
-                     cond
-                     delay
-                     unit compound-unit compound-unit/sig
-                     public private override
-                     inherit sequence))
-	(for-each (λ (x) 
-		    (hash-table-put! hash-table x 'lambda))
-		  '(
-		    cases
-                       instantiate super-instantiate
-                     syntax/loc quasisyntax/loc
-                     
-                     
-                     λ lambda let let* letrec recur
-                     lambda/kw
-                     letrec-values
-                     with-syntax
-		     with-continuation-mark
-                     module
-		     match match-let match-let* match-letrec
-                     let/cc let/ec letcc catch
-                     let-syntax letrec-syntax fluid-let-syntax letrec-syntaxes+values
-                     
-                     kernel-syntax-case
-                     syntax-case syntax-case* syntax-rules syntax-id-rules
-                     let-signature fluid-let
-                     let-struct let-macro let-values let*-values
-                     case when unless 
-                     let-enumerate
-                     class class* class-asi class-asi* class*/names
-                     class100 class100* class100-asi class100-asi* class100*/names
-                     rec
-                     make-object mixin
-                     define-some do opt-lambda
-		     send* with-method
-                     define-record
-                     local catch shared
-                     unit/sig unit/lang
-                     with-handlers
-                     interface
-                     parameterize
-                     call-with-input-file call-with-input-file* with-input-from-file
-                     with-input-from-port call-with-output-file
-                     with-output-to-file with-output-to-port))
-	(preferences:set-default 
-         'framework:tabify
-         (list hash-table #rx"^begin" #rx"^def" #f)
-         (λ (x)
-           (and (list? x)
-                (= (length x) 4)
-                (hash-table? (car x))
-                (andmap (λ (x) (or (regexp? x) (not x))) (cdr x)))))
-	(preferences:set-un/marshall
-	 'framework:tabify 
-	 (λ (t) (cons (hash-table-map (car t) list)
-                           (cdr t)))
-	 (λ (l) 
-           (and (list? l)
-                (= (length l) 4)
-                (andmap (λ (x) (or (regexp? x) (not x)))
-                        (cdr l))
-                (andmap (λ (x) (and (list? x)
-                                         (= 2 (length x))
-                                         (andmap symbol? x)))
-                        (car l))
-                (let ([h (make-hash-table)])
-                  (for-each (λ (x) (apply hash-table-put! h x)) (car l))
-                  (cons h (cdr l)))))))
-      
-      
-      (preferences:set-default 'framework:autosave-delay 300 number?)
-      (preferences:set-default 'framework:autosaving-on? #t boolean?)
-      (preferences:set-default 'framework:backup-files? #t boolean?)
-      (preferences:set-default 'framework:verify-exit #t boolean?)
-      (preferences:set-default 'framework:delete-forward? #t boolean?)
-      (preferences:set-default 'framework:show-periods-in-dirlist #f boolean?)
-      (preferences:set-default 'framework:file-dialogs 'std
-                               (λ (x) (and (memq x '(common std)) #t)))
-      
-      ;; scheme prefs
-      
-      (for-each (λ (line)
-                  (let ([sym (car line)]
-                        [color (cadr line)])
-                    (color-prefs:register-color-pref (scheme:short-sym->pref-name sym)
-                                                     (scheme:short-sym->style-name sym)
-                                                     color)))
-                (scheme:get-color-prefs-table))
-      (preferences:set-default 'framework:coloring-active #t boolean?)
-
-      (preferences:set-default 'framework:default-text-color 
-                               (send the-color-database find-color "Black")
-                               (λ (x) (is-a? x color%)))
-      
-      (preferences:set-un/marshall 'framework:default-text-color 
-                                   (λ (c) (list (send c red) (send c green) (send c blue)))
-                                   (λ (lst) 
-                                     (make-object color% (car lst) (cadr lst) (caddr lst))))
-      (preferences:add-callback 'framework:default-text-color
-                                (λ (p v)
-                                  (editor:set-default-font-color v)))
-      (editor:set-default-font-color (preferences:get 'framework:default-text-color))
-      
-      ;; groups
-      
-      (preferences:set-default 'framework:exit-when-no-frames #t boolean?)
-      (preferences:set 'framework:exit-when-no-frames #t)
-      
-      (exit:insert-can?-callback
-       (λ ()
-         (send (group:get-the-frame-group) can-close-all?)))    
-      
-      (exit:insert-on-callback
-       (λ ()
-         (send (group:get-the-frame-group) on-close-all)))
-      
-      ;; reset these -- they are only for the test suite.
-      ;; they do not need to be set across starting up and shutting down
-      ;; the application.
-      ;(preferences:set 'framework:file-dialogs 'std)
-      
-      (void))
+  (preferences:set-default 'framework:square-bracket:cond/offset
+                           '(("case-lambda" 0)
+                             ("cond" 0)
+                             ("field" 0)
+                             ("provide/contract" 0)
+                             ("new" 1)
+                             ("case" 1)
+                             ("syntax-case" 2)
+                             ("syntax-case*" 3))
+                           (λ (x) (and (list? x) (andmap (λ (x) (and (pair? x)
+                                                                     (string? (car x))
+                                                                     (pair? (cdr x))
+                                                                     (number? (cadr x))
+                                                                     (null? (cddr x))))
+                                                         x))))
+  (preferences:set-default 'framework:white-on-black? #f boolean?)
+  
+  (preferences:set-default 'framework:square-bracket:letrec
+                           '("let" 
+                             "let*" "let-values" "let*-values"
+                             "let-syntax" "let-struct" "let-syntaxes"
+                             "letrec"
+                             "letrec-syntaxes" "letrec-syntaxes+values" "letrec-values"
+                             "parameterize"
+                             "with-syntax")
+                           (λ (x) (and (list? x) (andmap string? x))))
+  
+  (preferences:set-default 'framework:case-sensitive-search?
+                           #f
+                           boolean?)
+  (color-prefs:set-default/color-scheme 'framework:basic-canvas-background "white" "black")
+  
+  (preferences:set-default 'framework:special-option-key #f boolean?)
+  (preferences:add-callback 'framework:special-option-key (λ (p v) (special-option-key v)))
+  (special-option-key (preferences:get 'framework:special-option-key))
+  
+  (preferences:set-default 'framework:fraction-snip-style 'mixed (λ (x) (memq x '(mixed improper))))
+  
+  (preferences:set-default 'framework:standard-style-list:font-name
+                           (get-family-builtin-face 'modern)
+                           string?)
+  
+  (preferences:set-default
+   'framework:standard-style-list:font-size
+   (let* ([txt (make-object text%)]
+          [stl (send txt get-style-list)]
+          [bcs (send stl basic-style)])
+     (send bcs get-size))
+   (λ (x) (and (number? x) (exact? x) (integer? x) (positive? x))))
+  
+  (preferences:set-default
+   'framework:standard-style-list:smoothing
+   'default
+   (λ (x) 
+     (memq x '(unsmoothed partly-smoothed smoothed default))))
+  
+  (editor:set-standard-style-list-pref-callbacks)
+  
+  (color-prefs:set-default/color-scheme
+   'framework:paren-match-color
+   (let ([gray-level
+          ;; old gray-level 192
+          (if (eq? (system-type) 'windows)
+              (* 3/4 256)
+              (- (* 7/8 256) 1))])
+     (make-object color% gray-level gray-level gray-level))
+   (make-object color% 50 50 50))
+  
+  (preferences:set-default 'framework:recently-opened-files/pos 
+                           null 
+                           (λ (x) (and (list? x) 
+                                       (andmap
+                                        (λ (x) 
+                                          (and (list? x)
+                                               (= 3 (length x))
+                                               (path? (car x))
+                                               (number? (cadr x))
+                                               (number? (caddr x))))
+                                        x))))
+  
+  (preferences:set-un/marshall
+   'framework:recently-opened-files/pos
+   (λ (l) (map (λ (ele) (cons (path->bytes (car ele)) (cdr ele))) l))
+   (λ (l) 
+     (let/ec k
+       (unless (list? l)
+         (k '()))
+       (map (λ (x)
+              (unless (and (list? x)
+                           (= 3 (length x))
+                           (bytes? (car x))
+                           (number? (cadr x))
+                           (number? (caddr x)))
+                (k '()))
+              (cons (bytes->path (car x)) (cdr x)))
+            l))))
+  
+  (preferences:set-default 'framework:last-directory 
+                           (find-system-path 'doc-dir) 
+                           (λ (x) (or (not x) path-string?)))
+  
+  (preferences:set-un/marshall 'framework:last-directory 
+                               (λ (x) (and (path? x) (path->bytes x)))
+                               (λ (x)
+                                 (and (bytes? x)
+                                      (bytes->path x))))
+  
+  (preferences:set-default 'framework:recent-max-count 
+                           50 
+                           (λ (x) (and (number? x)
+                                       (x . > . 0) 
+                                       (integer? x))))
+  (preferences:add-callback
+   'framework:recent-max-count
+   (λ (p v)
+     (handler:size-recently-opened-files v)))
+  
+  (preferences:set-default 'framework:last-url-string "" string?)
+  (preferences:set-default 'framework:recently-opened-sort-by 'age 
+                           (λ (x) (or (eq? x 'age) (eq? x 'name))))
+  (preferences:set-default 'framework:recent-items-window-w 400 number?)
+  (preferences:set-default 'framework:recent-items-window-h 600 number?)
+  (preferences:set-default 'framework:open-here? #f boolean?)
+  (preferences:set-default 'framework:show-delegate? #f boolean?)
+  (preferences:set-default 'framework:search-using-dialog? #t boolean?)
+  (preferences:set-default 'framework:windows-mdi #f boolean?)
+  (preferences:set-default 'framework:menu-bindings #t boolean?)
+  (preferences:set-default 'framework:verify-change-format #f boolean?)
+  (preferences:set-default 'framework:auto-set-wrap? #t boolean?)
+  (preferences:set-default 'framework:display-line-numbers #t boolean?)
+  (preferences:set-default 'framework:show-status-line #t boolean?)
+  (preferences:set-default 'framework:col-offsets #f boolean?)
+  
+  (preferences:set-default
+   'framework:print-output-mode
+   'standard
+   (λ (x) (or (eq? x 'standard) (eq? x 'postscript))))
+  
+  (preferences:set-default 'framework:highlight-parens #t boolean?)
+  (preferences:set-default 'framework:fixup-parens #t boolean?)
+  (preferences:set-default 'framework:fixup-open-parens #t boolean?)
+  (preferences:set-default 'framework:paren-match #t boolean?)
+  (let ([hash-table (make-hash-table)])
+    (for-each (λ (x) 
+                (hash-table-put! hash-table x 'define))
+              '())
+    (for-each (λ (x) 
+                (hash-table-put! hash-table x 'begin))
+              '(case-lambda
+                 match-lambda match-lambda*
+                 cond
+                 delay
+                 unit compound-unit compound-unit/sig
+                 public private override
+                 inherit sequence))
+    (for-each (λ (x) 
+                (hash-table-put! hash-table x 'lambda))
+              '(
+                cases
+                   instantiate super-instantiate
+                 syntax/loc quasisyntax/loc
+                 
+                 
+                 λ lambda let let* letrec recur
+                 lambda/kw
+                 letrec-values
+                 with-syntax
+                 with-continuation-mark
+                 module
+                 match match-let match-let* match-letrec
+                 let/cc let/ec letcc catch
+                 let-syntax letrec-syntax fluid-let-syntax letrec-syntaxes+values
+                 
+                 kernel-syntax-case
+                 syntax-case syntax-case* syntax-rules syntax-id-rules
+                 let-signature fluid-let
+                 let-struct let-macro let-values let*-values
+                 case when unless 
+                 let-enumerate
+                 class class* class-asi class-asi* class*/names
+                 class100 class100* class100-asi class100-asi* class100*/names
+                 rec
+                 make-object mixin
+                 define-some do opt-lambda
+                 send* with-method
+                 define-record
+                 local catch shared
+                 unit/sig unit/lang
+                 with-handlers
+                 interface
+                 parameterize
+                 call-with-input-file call-with-input-file* with-input-from-file
+                 with-input-from-port call-with-output-file
+                 with-output-to-file with-output-to-port))
+    (preferences:set-default 
+     'framework:tabify
+     (list hash-table #rx"^begin" #rx"^def" #f)
+     (λ (x)
+       (and (list? x)
+            (= (length x) 4)
+            (hash-table? (car x))
+            (andmap (λ (x) (or (regexp? x) (not x))) (cdr x)))))
+    (preferences:set-un/marshall
+     'framework:tabify 
+     (λ (t) (cons (hash-table-map (car t) list)
+                  (cdr t)))
+     (λ (l) 
+       (and (list? l)
+            (= (length l) 4)
+            (andmap (λ (x) (or (regexp? x) (not x)))
+                    (cdr l))
+            (andmap (λ (x) (and (list? x)
+                                (= 2 (length x))
+                                (andmap symbol? x)))
+                    (car l))
+            (let ([h (make-hash-table)])
+              (for-each (λ (x) (apply hash-table-put! h x)) (car l))
+              (cons h (cdr l)))))))
+  
+  
+  (preferences:set-default 'framework:autosave-delay 300 number?)
+  (preferences:set-default 'framework:autosaving-on? #t boolean?)
+  (preferences:set-default 'framework:backup-files? #t boolean?)
+  (preferences:set-default 'framework:verify-exit #t boolean?)
+  (preferences:set-default 'framework:delete-forward? #t boolean?)
+  (preferences:set-default 'framework:show-periods-in-dirlist #f boolean?)
+  (preferences:set-default 'framework:file-dialogs 'std
+                           (λ (x) (and (memq x '(common std)) #t)))
+  
+  ;; scheme prefs
+  
+  (for-each (λ (line white-on-black-line)
+              (let ([sym (car line)]
+                    [color (cadr line)]
+                    [white-on-black-color (cadr white-on-black-line)])
+                (color-prefs:register-color-pref (scheme:short-sym->pref-name sym)
+                                                 (scheme:short-sym->style-name sym)
+                                                 color
+                                                 white-on-black-color)))
+            (scheme:get-color-prefs-table)
+            (scheme:get-white-on-black-color-prefs-table))
+  (preferences:set-default 'framework:coloring-active #t boolean?)
+  
+  (color-prefs:set-default/color-scheme 'framework:default-text-color "black" "white")
+  (preferences:add-callback 'framework:default-text-color
+                            (λ (p v)
+                              (editor:set-default-font-color v)))
+  (editor:set-default-font-color (preferences:get 'framework:default-text-color))
+  
+  (color-prefs:set-default/color-scheme 'framework:delegatee-overview-color
+                                        "light blue"
+                                        (make-object color% 62 67 155))
+                                        
+  
+  ;; groups
+  
+  (preferences:set-default 'framework:exit-when-no-frames #t boolean?)
+  (preferences:set 'framework:exit-when-no-frames #t)
+  
+  (exit:insert-can?-callback
+   (λ ()
+     (send (group:get-the-frame-group) can-close-all?)))    
+  
+  (exit:insert-on-callback
+   (λ ()
+     (send (group:get-the-frame-group) on-close-all)))
+  
+  ;; reset these -- they are only for the test suite.
+  ;; they do not need to be set across starting up and shutting down
+  ;; the application.
+  ;(preferences:set 'framework:file-dialogs 'std)
+  
+  ;; setup the color scheme stuff
+  
+  
+  (void))
diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss
index 255ed98c..80441410 100644
--- a/collects/framework/private/scheme.ss
+++ b/collects/framework/private/scheme.ss
@@ -267,18 +267,40 @@
   ;;;    ;;;  ;;; ;;;  ;;;  ;; ; ;;  ;;;     ;      ;;;   ;;;  ;;   ;;   ;;; 
                                                                              
  
-      (define color-prefs-table
-        (let ([constant-green (make-object color% 41 128 38)]
-              [symbol-blue (make-object color% 38 38 128)])
-          `((symbol ,symbol-blue ,(string-constant scheme-mode-color-symbol))
-            (keyword ,symbol-blue ,(string-constant scheme-mode-color-keyword))
-            (comment ,(make-object color% 194 116 31) ,(string-constant scheme-mode-color-comment))
-            (string ,constant-green ,(string-constant scheme-mode-color-string))
-            (constant ,constant-green ,(string-constant scheme-mode-color-constant))
-            (parenthesis ,(make-object color% "brown") ,(string-constant scheme-mode-color-parenthesis))
-            (error ,(make-object color% "red") ,(string-constant scheme-mode-color-error))
-            (other ,(make-object color% "black") ,(string-constant scheme-mode-color-other)))))
-      (define (get-color-prefs-table) color-prefs-table)
+  (define color-prefs-table
+    (let ([constant-green (make-object color% 41 128 38)]
+          [symbol-blue (make-object color% 38 38 128)])
+      `((symbol ,symbol-blue ,(string-constant scheme-mode-color-symbol))
+        (keyword ,symbol-blue ,(string-constant scheme-mode-color-keyword))
+        (comment ,(make-object color% 194 116 31) ,(string-constant scheme-mode-color-comment))
+        (string ,constant-green ,(string-constant scheme-mode-color-string))
+        (constant ,constant-green ,(string-constant scheme-mode-color-constant))
+        (parenthesis ,(make-object color% "brown") ,(string-constant scheme-mode-color-parenthesis))
+        (error ,(make-object color% "red") ,(string-constant scheme-mode-color-error))
+        (other ,(make-object color% "black") ,(string-constant scheme-mode-color-other)))))
+  
+  (define white-on-black-color-prefs-table
+    (let* ([sym/kwd (make-object color% 102 102 255)]
+           [new-entries
+            `((symbol ,sym/kwd)
+              (keyword ,sym/kwd)
+              (comment ,(make-object color% 249 148 40))
+              (string ,(make-object color% 51 174 51))
+              (constant ,(make-object color% 60 194 57))
+              (parenthesis ,(make-object color% 151 69 43))
+              (other ,(make-object color% "white")))])
+      (map 
+       (λ (line)
+         (let ([new (assoc (car line) new-entries)])
+           (if new
+               (list* (car line)
+                      (cadr new)
+                      (cddr line))
+               line)))
+       color-prefs-table)))
+
+  (define (get-color-prefs-table) color-prefs-table)
+  (define (get-white-on-black-color-prefs-table) white-on-black-color-prefs-table)
       
       (define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym)))
       (define sn-hash (make-hash-table))
diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss
index 2338956b..d0bf04e0 100644
--- a/collects/framework/private/sig.ss
+++ b/collects/framework/private/sig.ss
@@ -369,7 +369,8 @@
      build-color-selection-panel
      add-background-preferences-panel
      marshall-style
-     unmarshall-style))  
+     unmarshall-style
+     set-default/color-scheme))  
   
   (define-signature scheme-class^
     (text<%>
@@ -393,6 +394,7 @@
      add-coloring-preferences-panel
      
      get-color-prefs-table
+     get-white-on-black-color-prefs-table
      short-sym->pref-name
      short-sym->style-name