From 1186f23543ccb017e35b40ffc012aa971f21f764 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sun, 1 Sep 2013 15:05:28 -0500
Subject: [PATCH] add support for color schemes to the framework and use it in
 DrRacket

---
 pkgs/drracket-pkgs/drracket/drracket/info.rkt |   9 +
 .../drracket/drracket/private/main.rkt        |  52 +-
 .../drracket/private/syncheck/gui.rkt         |  72 +-
 .../drracket/scribblings/tools/tools.scrbl    |  12 +-
 pkgs/gui-pkgs/gui-lib/framework/main.rkt      | 167 ++++-
 .../gui-lib/framework/private/canvas.rkt      |  10 +-
 .../gui-lib/framework/private/color-prefs.rkt | 670 +++++++++++++++---
 .../gui-lib/framework/private/color.rkt       |   5 +-
 .../gui-lib/framework/private/main.rkt        |  74 +-
 .../gui-lib/framework/private/sig.rkt         |  13 +-
 pkgs/htdp-pkgs/htdp-lib/lang/htdp-langs.rkt   |  52 +-
 .../private/english-string-constants.rkt      |   6 +-
 12 files changed, 892 insertions(+), 250 deletions(-)

diff --git a/pkgs/drracket-pkgs/drracket/drracket/info.rkt b/pkgs/drracket-pkgs/drracket/drracket/info.rkt
index 051e68df04..f475c1562f 100644
--- a/pkgs/drracket-pkgs/drracket/drracket/info.rkt
+++ b/pkgs/drracket-pkgs/drracket/drracket/info.rkt
@@ -12,3 +12,12 @@
 (define release-note-files (list (list "DrRacket" "HISTORY.txt")))
 
 (define copy-man-pages '("drracket.1"))
+
+(define framework:color-schemes 
+  (list (hash 
+         'name 'modern-color-scheme
+         'colors
+         '((framework:syntax-color:scheme:symbol #(211 72 255))
+           (framework:syntax-color:scheme:constant #(211 72 255))
+           (framework:syntax-color:scheme:comment #(194 158 31))
+           (framework:syntax-color:scheme:parenthesis #(0 150 255))))))
diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/main.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/main.rkt
index f441c32766..2ad5d20a6e 100644
--- a/pkgs/drracket-pkgs/drracket/drracket/private/main.rkt
+++ b/pkgs/drracket-pkgs/drracket/drracket/private/main.rkt
@@ -263,6 +263,7 @@
   
 
 (drracket:font:setup-preferences)
+(color-prefs:add-color-scheme-preferences-panel)
 (color-prefs:add-background-preferences-panel)
 (racket:add-preferences-panel)
 (racket:add-coloring-preferences-panel)
@@ -588,19 +589,19 @@
 (define repl-error-pref 'drracket:read-eval-print-loop:error-color)
 (define repl-out-pref 'drracket:read-eval-print-loop:out-color)
 (define repl-value-pref 'drracket:read-eval-print-loop:value-color)
-(color-prefs:register-color-preference repl-value-pref
-                                       "text:ports value"
-                                       (make-object color% 0 0 175)
-                                       (make-object color% 57 89 216))
-(color-prefs:register-color-preference repl-error-pref
-                                       "text:ports err"
-                                       (let ([sd (make-object style-delta% 'change-italic)])
-                                         (send sd set-delta-foreground (make-object color% 255 0 0))
-                                         sd))
-(color-prefs:register-color-preference repl-out-pref
-                                       "text:ports out"
-                                       (make-object color% 150 0 150)
-                                       (make-object color% 192 46 214))
+(color-prefs:add-color-scheme-entry repl-value-pref
+                                    #:style "text:ports value"
+                                    (make-object color% 0 0 175)
+                                    (make-object color% 57 89 216))
+(color-prefs:add-color-scheme-entry repl-error-pref
+                                    #:style "text:ports err"
+                                    (make-object color% 255 0 0)
+                                    (make-object color% 255 0 0)
+                                    #:italic? #t)
+(color-prefs:add-color-scheme-entry repl-out-pref
+                                    #:style "text:ports out"
+                                    (make-object color% 150 0 150)
+                                    (make-object color% 192 46 214))
 (color-prefs:add-to-preferences-panel 
  (string-constant repl-colors)
  (λ (parent)
@@ -621,15 +622,15 @@
 (define test-coverage-on-style-pref (string->symbol drracket:debug:test-coverage-on-style-name))
 (define test-coverage-off-style-pref (string->symbol drracket:debug:test-coverage-off-style-name))
 
-(color-prefs:register-color-preference test-coverage-on-style-pref
-                                       drracket:debug:test-coverage-on-style-name
-                                       (send the-color-database find-color "black")
-                                       (send the-color-database find-color "white"))
-(color-prefs:register-color-preference test-coverage-off-style-pref
-                                       drracket:debug:test-coverage-off-style-name
-                                       (send the-color-database find-color "orange")
-                                       (send the-color-database find-color "indianred")
-                                       #:background (send the-color-database find-color "black"))
+(color-prefs:add-color-scheme-entry test-coverage-on-style-pref
+                                    #:style drracket:debug:test-coverage-on-style-name
+                                    "black"
+                                    "white")
+(color-prefs:add-color-scheme-entry test-coverage-off-style-pref
+                                    #:style drracket:debug:test-coverage-off-style-name
+                                    "orange"
+                                    "indianred"
+                                    #:background "black")
 (color-prefs:add-to-preferences-panel 
  "Module Language"
  (λ (parent)
@@ -640,7 +641,8 @@
    (color-prefs:build-color-selection-panel parent
                                             test-coverage-off-style-pref
                                             drracket:debug:test-coverage-off-style-name
-                                            (string-constant test-coverage-off))))
+                                            (string-constant test-coverage-off)
+                                            #:background? #t)))
 
 (drracket:module-language:initialize-prefs-panel)
 
@@ -707,6 +709,10 @@
      (when (eq? (system-type) 'macosx)
        (new separator-menu-item% [parent windows-menu])))))
 
+;; this needs to happen after all of the earlier preferences setup
+;; so that the color-prefs knowns about all the new colors names
+(color-prefs:register-info-based-color-schemes)
+
 ;; Check for any files lost last time.
 ;; Ignore the framework's empty frames test, since
 ;;   the autosave information window may appear and then
diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/gui.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/gui.rkt
index b9991e30c1..93d31bd93c 100644
--- a/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/gui.rkt
+++ b/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/gui.rkt
@@ -135,43 +135,43 @@ If the namespace does not, they are colored the unbound color.
                                            both-obligation-style-name
                                            cs-both-obligation-color))
 
-(color-prefs:register-color-preference lexically-bound-variable-style-pref
-                                       lexically-bound-variable-style-name
-                                       (make-object color% 81 112 203)
-                                       (make-object color% 50 163 255))
-(color-prefs:register-color-preference set!d-variable-style-pref
-                                       set!d-variable-style-name
-                                       (send the-color-database find-color "firebrick")
-                                       (send the-color-database find-color "pink"))
-(color-prefs:register-color-preference unused-require-style-pref
-                                       unused-require-style-name
-                                       (send the-color-database find-color "red")
-                                       (send the-color-database find-color "pink"))
-(color-prefs:register-color-preference free-variable-style-pref
-                                       free-variable-style-name
-                                       (send the-color-database find-color "red")
-                                       (send the-color-database find-color "pink"))
+(color-prefs:add-color-scheme-entry lexically-bound-variable-style-pref
+                                    #:style lexically-bound-variable-style-name
+                                    (make-object color% 81 112 203)
+                                    (make-object color% 50 163 255))
+(color-prefs:add-color-scheme-entry set!d-variable-style-pref
+                                    #:style set!d-variable-style-name
+                                    (send the-color-database find-color "firebrick")
+                                    (send the-color-database find-color "pink"))
+(color-prefs:add-color-scheme-entry unused-require-style-pref
+                                    #:style unused-require-style-name
+                                    (send the-color-database find-color "red")
+                                    (send the-color-database find-color "pink"))
+(color-prefs:add-color-scheme-entry free-variable-style-pref
+                                    #:style free-variable-style-name
+                                    (send the-color-database find-color "red")
+                                    (send the-color-database find-color "pink"))
 
-(color-prefs:register-color-preference imported-variable-style-pref
-                                       imported-variable-style-name
-                                       (make-object color% 68 0 203)
-                                       (make-object color% 166 0 255))
-(color-prefs:register-color-preference my-obligation-style-pref
-                                       my-obligation-style-name
-                                       (send the-color-database find-color "firebrick")
-                                       (send the-color-database find-color "pink"))
-(color-prefs:register-color-preference their-obligation-style-pref
-                                       their-obligation-style-name
-                                       (make-object color% 0 116 0)
-                                       (send the-color-database find-color "limegreen"))
-(color-prefs:register-color-preference unk-obligation-style-pref
-                                       unk-obligation-style-name
-                                       (send the-color-database find-color "black")
-                                       (send the-color-database find-color "white"))
-(color-prefs:register-color-preference both-obligation-style-pref
-                                       both-obligation-style-name
-                                       (make-object color% 139 142 28)
-                                       (send the-color-database find-color "khaki"))
+(color-prefs:add-color-scheme-entry imported-variable-style-pref
+                                    #:style imported-variable-style-name
+                                    (make-object color% 68 0 203)
+                                    (make-object color% 166 0 255))
+(color-prefs:add-color-scheme-entry my-obligation-style-pref
+                                    #:style my-obligation-style-name
+                                    (send the-color-database find-color "firebrick")
+                                    (send the-color-database find-color "pink"))
+(color-prefs:add-color-scheme-entry their-obligation-style-pref
+                                    #:style their-obligation-style-name
+                                    (make-object color% 0 116 0)
+                                    (send the-color-database find-color "limegreen"))
+(color-prefs:add-color-scheme-entry unk-obligation-style-pref
+                                    #:style unk-obligation-style-name
+                                    (send the-color-database find-color "black")
+                                    (send the-color-database find-color "white"))
+(color-prefs:add-color-scheme-entry both-obligation-style-pref
+                                    #:style both-obligation-style-name
+                                    (make-object color% 139 142 28)
+                                    (send the-color-database find-color "khaki"))
 
 (define tool@ 
   (unit 
diff --git a/pkgs/drracket-pkgs/drracket/scribblings/tools/tools.scrbl b/pkgs/drracket-pkgs/drracket/scribblings/tools/tools.scrbl
index c202d71ae3..fa67e7b450 100644
--- a/pkgs/drracket-pkgs/drracket/scribblings/tools/tools.scrbl
+++ b/pkgs/drracket-pkgs/drracket/scribblings/tools/tools.scrbl
@@ -570,8 +570,18 @@ has.
 @index{modes}
 @index{scheme mode}
 @index{racket mode}
-@index{definitions-text-surrogate}
 
+@subsection{Color Schemes}
+
+DrRacket uses the framework's color schemes to colorize
+source text and other aspects of itself. See 
+@racket[color-prefs:register-info-based-color-schemes] for
+details on how to add new color schemes via @filepath{info.rkt}
+files.
+
+@subsection{General-purpose Modes}
+
+@index{definitions-text-surrogate}
 DrRacket provides support for multiple editor modes based on the
 @tt{#lang} line at the beginning of the editor. If the 
 @onscreen{Modes} submenu of the @onscreen{Edit} menu has
diff --git a/pkgs/gui-pkgs/gui-lib/framework/main.rkt b/pkgs/gui-pkgs/gui-lib/framework/main.rkt
index 0689af06df..1c502dc912 100644
--- a/pkgs/gui-pkgs/gui-lib/framework/main.rkt
+++ b/pkgs/gui-pkgs/gui-lib/framework/main.rkt
@@ -28,7 +28,8 @@
                        framework/decorated-editor-snip
                        framework/private/decorated-editor-snip))
 
-(require (for-doc scheme/base scribble/manual framework/private/mapdesc))
+(require (for-doc racket/base scribble/manual framework/private/mapdesc
+                  setup/getinfo racket/pretty))
 
 (provide-signature-elements
  (prefix application: framework:application-class^)
@@ -711,7 +712,7 @@
 
  (proc-doc/names
   frame:reorder-menus
-  ((is-a?/c frame%) . -> . void?)
+  (-> (is-a?/c frame%) void?)
   (frame)
   @{Re-orders the menus in a frame.  It moves the ``File'' and ``Edit'' menus
     to the front of the menubar and moves the ``Windows'' and ``Help'' menus to
@@ -1621,7 +1622,7 @@
 
  (proc-doc/names
   editor:set-standard-style-list-delta
-  (string? (is-a?/c style-delta%) . -> . void?)
+  (-> string? (is-a?/c style-delta%) void?)
   (name delta)
   @{Finds (or creates) the style named by @racket[name] in the result of
     @racket[editor:get-standard-style-list] and sets its delta to
@@ -1756,7 +1757,7 @@
     @racket[preferences:set-un/marshall] with appropriate arguments to register
     the preference.})
 
- (proc-doc/names
+ (proc-doc/names 
   color-prefs:register-color-preference
   (->* (symbol? string? (or/c (is-a?/c color%) (is-a?/c style-delta%)))
        ((or/c string? (is-a?/c color%) #f)
@@ -1787,10 +1788,8 @@
     @racket[white-on-black-color] to register this preference with
     @racket[color-prefs:set-default/color-scheme].
     
-    If either @racket[background] is
-    not @racket[#f], then it is used to construct the default background color
-    for the style delta.
-    
+    If @racket[background] is not @racket[#f], then it is used to construct the
+    default background color for the style delta.
     })
 
  (proc-doc/names
@@ -1849,7 +1848,157 @@
   (-> any)
   ()
   @{Sets the colors registered by @racket[color-prefs:register-color-preference]
-    to their black-on-white variety.}))
+    to their black-on-white variety.})
+ 
+ (proc-doc
+  color-prefs:add-color-scheme-entry
+  (->i ([name symbol?]
+        [black-on-white-color (or/c string? (is-a?/c color%))]
+        [white-on-black-color (or/c string? (is-a?/c color%))])
+       (#:style 
+        [style (or/c #f string?)]
+        #:bold? [bold? (style) (if style boolean? #f)]
+        #:underline? [underline? (style) (if style boolean? #f)]
+        #:italic? [italic? (style) (if style boolean? #f)]
+        #:background
+        [background (style)
+                    (if style
+                        (or/c #f string? (is-a?/c color%))
+                        #f)])
+       [result void?])
+  (#f #f #f #f #f)
+  @{Registers a new color or style named @racket[name] for use in the color schemes. 
+    If @racket[style] is provided, a new style is registered; if not a color is
+    registered.})
+ 
+ (proc-doc
+  color-prefs:add-color-scheme-preferences-panel
+  (-> void?)
+  @{Adds a panel for choosing a color-scheme to the preferences dialog.})
+ 
+ (proc-doc
+  color-prefs:register-info-based-color-schemes
+  (-> void?)
+  @{Reads 
+    the @filepath{info.rkt} file in each collection, looking for the key
+    @index{framework:color-schemes}
+    @racket['framework:color-schemes]. Each definition must bind
+    a list of hash tables, each of which introduces a new
+    color scheme. Each hash table should have keys that specify
+    details of the color scheme, as follows:
+    @itemlist[@item{@racket['name]: must be either a string or a symbol;
+                     if it is a symbol, it is passed to @racket[dynamic-string-constant]
+                     to get the name; otherwise it is used as the name directly.
+                     If absent, the name of the directory containing the @filepath{info.rkt}
+                     file is used as the name.}
+               @item{@racket['white-on-black-base?]: must be a boolean indicating if this
+                      color-scheme is based on an inverted color scheme. If absent, it
+                      is @racket[#f].}
+               @item{@racket['example]: must be a string and is used in the preferences dialog
+                      to show an example of the color scheme. If absent, the string used in
+                      the ``Classic'' color scheme is used.}
+               @item{@racket['colors]: must be a non-empty list whose first position
+                      is a symbol, naming a color or style. The rest of the elements describe
+                      the style or color. In either case, an element may be a vector of three
+                      bytes: this describes a color (in r/g/b order) with an alpha value of
+                      @racket[1.0]. The vector may also have three bytes followed by a real
+                      number between @racket[0] and @racket[1], which is used as the alpha
+                      value. If the name corresponds to a style, then the list may also contain
+                      the symbols @racket['bold], @racket['italic], or @racket['underline].}]
+    
+    The names of the colors and styles are extensible; new ones can be added by calling
+    @racket[color-prefs:add-color-scheme-entry]. When
+    @racket[color-prefs:register-info-based-color-schemes]
+    is called, it logs the active set of color names and style names to the @tt{color-scheme}
+    logger at the info level. So, for example, starting up DrRacket like this:
+    @tt{racket -W info@"@"color-scheme -l drracket} will print out the styles used in your
+    version of DrRacket.
+    
+    As an example, this is the specification of the @racket["Modern"] style:
+    @(let ()
+       (define pth (collection-file-path "info.rkt" "drracket"))
+       (define-values (base name dir?) (split-path pth))
+       (define info (get-info/full base))
+       (unless info (error 'framework/main.rkt "could not find example for modern color scheme"))
+       (parameterize ([pretty-print-columns 60])
+         (codeblock (pretty-format (info 'framework:color-schemes)))))})
+ 
+ (proc-doc/names
+  color-prefs:set-current-color-scheme
+  (-> symbol? void?)
+  (name)
+  @{Sets
+    the current color scheme to @racket[name], if @racket[name] is
+    @racket[color-prefs:known-color-scheme-name?]. Otherwise, does nothing.})
+ 
+ (proc-doc
+  color-prefs:get-current-color-scheme
+  (-> color-prefs:color-scheme-style-name?)
+  @{Returns the current color scheme's name.})
+ 
+ (proc-doc/names
+  color-prefs:known-color-scheme-name?
+  (-> any/c boolean?)
+  (name)
+  @{Returns @racket[#t] if the input is a @racket[symbol?] that names
+            a color or style that is part of the current color scheme.
+            
+            In order to return @racket[#t], @racket[name] must have been
+            passed as the first argument to @racket[color-prefs:add-color-scheme-entry].})
+ 
+ (proc-doc/names
+  color-prefs:color-scheme-style-name?
+  (-> any/c boolean?)
+  (name)
+  @{Returns @racket[#t] if @racket[name] is a known color scheme name,
+            and is connected to a style. 
+            
+            In order to return @racket[#t], @racket[name] must have been
+            passed as the first argument to @racket[color-prefs:add-color-scheme-entry]
+            and the @racket[#:style] argument must have also been passed.})
+ 
+ (proc-doc 
+  color-prefs:lookup-in-color-scheme
+  (->i ([name color-prefs:known-color-scheme-name?])
+       ()
+       [result (name)
+               (if (color-prefs:color-scheme-style-name? name)
+                   (is-a?/c style-delta%)
+                   (is-a?/c color%))])
+  @{Returns the current style delta or color associated with @racket[name].})
+ 
+ (proc-doc
+  color-prefs:set-in-color-scheme
+  (->i ([name color-prefs:known-color-scheme-name?]
+        [new-val (name)
+                 (if (color-prefs:color-scheme-style-name? name)
+                     (is-a?/c style-delta%)
+                     (is-a?/c color%))])
+       ()
+       [result void?])
+  @{Updates the current color or style delta associated with 
+    @racket[name] in the current color scheme.})
+ 
+ (proc-doc
+  color-prefs:register-color-scheme-entry-change-callback
+  (->i ([name color-prefs:known-color-scheme-name?]
+        [fn (name)
+            (-> (if (color-prefs:color-scheme-style-name? name)
+                    (is-a?/c style-delta%)
+                    (is-a?/c color%))
+                any)])
+       ([weak? boolean?])
+       [result void?])
+  (#f)
+  @{Registers a callback that is invoked whenever the color mapped by
+    @racket[name] changes. Changes may happen due to calls to
+    @racket[color-prefs:set-in-color-scheme] or due to calls to 
+    @racket[color-prefs:set-current-color-scheme].
+    
+    If @racket[weak?] is @racket[#t], the @racket[fn] argument is held
+    onto weakly; otherwise it is held onto strongly.})
+ )
+
 
 (define-syntax (racket:-reprovides stx)
   #`(provide
diff --git a/pkgs/gui-pkgs/gui-lib/framework/private/canvas.rkt b/pkgs/gui-pkgs/gui-lib/framework/private/canvas.rkt
index 463821e0fd..8ba2e1f2c4 100644
--- a/pkgs/gui-pkgs/gui-lib/framework/private/canvas.rkt
+++ b/pkgs/gui-pkgs/gui-lib/framework/private/canvas.rkt
@@ -6,7 +6,8 @@
   
   (import mred^
           [prefix frame: framework:frame^]
-          [prefix text: framework:text^])
+          [prefix text: framework:text^]
+          [prefix color-prefs: framework:color-prefs^])
   
   (export (rename framework:canvas^
                   (-color% color%)))
@@ -20,11 +21,12 @@
   
   (define color-mixin
     (mixin (basic<%>) (color<%>)
-      (define callback (λ (p v) (set-canvas-background v)))
+      (define callback (λ (v) (set-canvas-background v)))
       (super-new)
       (inherit set-canvas-background)
-      (set-canvas-background (preferences:get 'framework:basic-canvas-background))
-      (preferences:add-callback 'framework:basic-canvas-background callback #t)))
+      (set-canvas-background (color-prefs:lookup-in-color-scheme 'framework:basic-canvas-background))
+      (color-prefs:register-color-scheme-entry-change-callback
+       'framework:basic-canvas-background callback #t)))
   
   (define delegate<%> (interface (basic<%>)))
   
diff --git a/pkgs/gui-pkgs/gui-lib/framework/private/color-prefs.rkt b/pkgs/gui-pkgs/gui-lib/framework/private/color-prefs.rkt
index 0b84c7e738..dba65bd5fd 100644
--- a/pkgs/gui-pkgs/gui-lib/framework/private/color-prefs.rkt
+++ b/pkgs/gui-pkgs/gui-lib/framework/private/color-prefs.rkt
@@ -1,8 +1,14 @@
 #lang racket/unit
-  (require mzlib/class
-           mred
+  (require racket/class
+           racket/gui/base
            string-constants
            racket/match
+           racket/contract/base
+           racket/set
+           setup/getinfo
+           setup/collects
+           string-constants
+           racket/pretty
            "../preferences.rkt"
            "sig.rkt")
   
@@ -19,12 +25,25 @@
   
   ;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void
   ;; constructs a panel containg controls to configure the preferences panel.
-  (define (build-color-selection-panel parent pref-sym style-name example-text #:background? [background? #f])
+  (define (build-color-selection-panel parent pref-sym style-name example-text 
+                                       #:background? [background? #f])
+    (define (get-from-pref-sym)
+      (if (set-member? known-style-names pref-sym)
+          (lookup-in-color-scheme pref-sym)
+          (preferences:get pref-sym)))
+    (define (set-via-pref-sym delta) 
+      (if (set-member? known-style-names pref-sym)
+          (set-in-color-scheme pref-sym delta)
+          (preferences:set pref-sym delta)))
+    (define (add-pref-sym-callback f) 
+      (if (set-member? known-style-names pref-sym)
+          (register-color-scheme-entry-change-callback pref-sym f)
+          (preferences:add-callback pref-sym (λ (p sd) (f sd)))))
     (define (update-style-delta func)
       (let ([working-delta (new style-delta%)])
-        (send working-delta copy (preferences:get pref-sym))
+        (send working-delta copy (get-from-pref-sym))
         (func working-delta)
-        (preferences:set pref-sym working-delta)))
+        (set-via-pref-sym working-delta)))
     (define hp (new horizontal-panel%
                     [parent parent]
                     [style '(border)]
@@ -138,7 +157,7 @@
                             hp)]
                 [callback
                  (λ (color-button evt)
-                   (let* ([add (send (preferences:get pref-sym) get-foreground-add)]
+                   (let* ([add (send (get-from-pref-sym) get-foreground-add)]
                           [color (make-object color%
                                    (send add get-r)
                                    (send add get-g)
@@ -147,7 +166,8 @@
                            (get-color-from-user
                             (format (string-constant syntax-coloring-choose-color) example-text)
                             (send color-button get-top-level-window)
-                            color)])
+                            color
+                            '(alpha))])
                      (when users-choice
                        (update-style-delta
                         (λ (delta)
@@ -162,7 +182,7 @@
                             hp)]
                 [callback
                  (λ (color-button evt)
-                   (let* ([add (send (preferences:get pref-sym) get-background-add)]
+                   (let* ([add (send (get-from-pref-sym) get-background-add)]
                           [color (make-object color%
                                    (send add get-r)
                                    (send add get-g)
@@ -171,7 +191,8 @@
                            (get-color-from-user
                             (format (string-constant syntax-coloring-choose-color) example-text)
                             (send color-button get-top-level-window)
-                            color)])
+                            color
+                            '(alpha))])
                      (when users-choice
                        (update-style-delta
                         (λ (delta)
@@ -197,12 +218,11 @@
       (send c min-height 50)
       (send c stretchable-height #f))
     
-    (preferences:add-callback
-     pref-sym
-     (λ (p sd)
-       (send slant-check set-value (or (eq? (send style get-style) 'slant)
-                                       (eq? (send style get-style) 'italic)))
-       (send bold-check set-value (eq? (send sd get-weight-on) 'bold))
+    (add-pref-sym-callback
+     (λ (sd)
+       (send slant-check set-value (or (equal? (send style get-style) 'slant)
+                                       (equal? (send style get-style) 'italic)))
+       (send bold-check set-value (equal? (send sd get-weight-on) 'bold))
        (send underline-check set-value (send sd get-underlined-on))
        (send smoothing-menu set-selection (smoothing->index (send sd get-smoothing-on)))))
     (void))
@@ -304,26 +324,28 @@
       
       style))
   
-  (define (make-style-delta color bold? underline? italic?)
-    (let ((sd (make-object style-delta%)))
-      (send sd set-delta-foreground color)
-      (cond
-        (bold?
-         (send sd set-weight-on 'bold)
-         (send sd set-weight-off 'base))
-        (else
-         (send sd set-weight-on 'base)
-         (send sd set-weight-off 'bold)))
-      (send sd set-underlined-on underline?)
-      (send sd set-underlined-off (not underline?))
-      (cond
-        (italic?
-         (send sd set-style-on 'italic)
-         (send sd set-style-off 'base))
-        (else
-         (send sd set-style-on 'base)
-         (send sd set-style-off 'italic)))
-      sd))
+  (define (make-style-delta color bold? underline? italic? #:background [background #f])
+    (define sd (make-object style-delta%))
+    (send sd set-delta-foreground color)
+    (cond
+      [bold?
+       (send sd set-weight-on 'bold)
+       (send sd set-weight-off 'base)]
+      [else
+       (send sd set-weight-on 'base)
+       (send sd set-weight-off 'bold)])
+    (send sd set-underlined-on underline?)
+    (send sd set-underlined-off (not underline?))
+    (cond
+      [italic?
+       (send sd set-style-on 'italic)
+       (send sd set-style-off 'base)]
+      [else
+       (send sd set-style-on 'base)
+       (send sd set-style-off 'italic)])
+    (when background
+      (send sd set-delta-background background))
+    sd)
   
   (define (add-background-preferences-panel)
     (preferences:add-panel
@@ -366,25 +388,8 @@
             'framework:paren-color-scheme
             (λ (p v)
               (update-choice v)))
-           (update-choice (preferences:get 'framework:paren-color-scheme)))
-         
-         (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) 
-                            (preferences:set 'framework:white-on-black? #t)
-                            (white-on-black))])
-           (new button%
-                [label (string-constant black-on-white-color-scheme)]
-                [parent hp]
-                [callback (λ (x y) 
-                            (preferences:set 'framework:white-on-black? #f)
-                            (black-on-white))]))))))
-  
-  
+           (update-choice (preferences:get 'framework:paren-color-scheme)))))))
+    
   (define (build-text-foreground-selection-panel parent pref-sym style-name example-text)
     (define hp (new horizontal-panel% 
                     (parent parent)
@@ -414,9 +419,10 @@
                       (get-color-from-user
                        (format (string-constant syntax-coloring-choose-color) example-text)
                        (send color-button get-top-level-window)
-                       (preferences:get pref-sym))])
+                       (lookup-in-color-scheme pref-sym)
+                       '(alpha))])
                  (when users-choice
-                   (preferences:set pref-sym users-choice)))))))
+                   (set-in-color-scheme pref-sym users-choice)))))))
     (define style (send (send e get-style-list) find-named-style style-name))
     
     (send c set-line-count 1)
@@ -426,39 +432,46 @@
     (send e set-position 0))
   
   (define (add-solid-color-config label parent pref-id)
-    (letrec ([panel (new vertical-panel% (parent parent) (stretchable-height #f))]
-             [hp (new horizontal-panel% (parent panel) (stretchable-height #f))]
-             [msg (new message% (parent hp) (label label))]
-             [canvas
-              (new canvas%
-                   (parent hp)
-                   (paint-callback
-                    (λ (c dc)
-                      (draw (preferences:get pref-id)))))]
-             [draw
-              (λ (clr)
-                (let ([dc (send canvas get-dc)])
-                  (let-values ([(w h) (send canvas get-client-size)])
-                    (send dc set-brush (send the-brush-list find-or-create-brush clr 'solid))
-                    (send dc set-pen (send the-pen-list find-or-create-pen clr 1 'solid))
-                    (send dc draw-rectangle 0 0 w h))))]
-             [button
-              (new button% 
-                   (label (string-constant cs-change-color))
-                   (parent hp)
-                   (callback
-                    (λ (x y)
-                      (let ([color (get-color-from-user
-                                    (string-constant choose-a-background-color)
-                                    (send hp get-top-level-window)
-                                    (preferences:get pref-id))])
-                        (when color
-                          (preferences:set pref-id color))))))])
-      (preferences:add-callback
-       pref-id
-       (λ (p v) (draw v)))
-      panel))
-  
+    (define panel (new vertical-panel% (parent parent) (stretchable-height #f)))
+    (define hp (new horizontal-panel% (parent panel) (stretchable-height #f)))
+    (define msg (new message% (parent hp) (label label)))
+    (define canvas
+      (new canvas%
+           (parent hp)
+           (paint-callback
+            (λ (c dc)
+              (draw (lookup-in-color-scheme pref-id))))))
+    (define (draw clr)
+      (define dc (send canvas get-dc))
+      (define-values (w h) (send canvas get-client-size))
+      (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
+      (send dc set-brush (if (preferences:get 'framework:white-on-black?)
+                             "black"
+                             "white")
+            'solid)
+      (send dc draw-rectangle 0 0 w h)
+      (send dc set-brush (send the-brush-list find-or-create-brush clr 'solid))
+      (send dc draw-rectangle 0 0 w h))
+    (define button
+      (new button% 
+           (label (string-constant cs-change-color))
+           (parent hp)
+           (callback
+            (λ (x y)
+              (define color (get-color-from-user
+                             (string-constant choose-a-background-color)
+                             (send hp get-top-level-window)
+                             (lookup-in-color-scheme pref-id)
+                             '(alpha)))
+              (when color
+                (set-in-color-scheme pref-id color))))))
+    (register-color-scheme-entry-change-callback
+     pref-id
+     (λ (v) 
+       ;; the pref should be updated on the next event callback
+       (queue-callback (λ () (send canvas refresh)))))
+    panel)
+
   ;; add-to-preferences-panel : string (vertical-panel -> void) -> void
   (define (add-to-preferences-panel panel-name func)
     (preferences:add-panel
@@ -512,17 +525,19 @@
       (preferences:set-un/marshall 
        pref-sym
        (λ (clr) (list (send clr red) (send clr green) (send clr blue) (send clr alpha)))
-       (λ (lst) 
-         (match lst
-           [(list (? byte? red) (? byte? green) (? byte? blue))
-            ;; old prefs-- before there were no alpha components to color% objects
-            ;; and so only r/g/b was saved.
-            (make-object color% red green blue)]
-           [(list (? byte? red) (? byte? green) (? byte? blue) (? (λ (x) (and (real? x) (<= 0 x 1))) α))
-            (make-object color% red green blue α)]
-           [else #f])))
+       unmarshall-color)
       (void)))
   
+(define (unmarshall-color lst)
+  (match lst
+    [(list (? byte? red) (? byte? green) (? byte? blue))
+     ;; old prefs-- before there were no alpha components to color% objects
+     ;; and so only r/g/b was saved.
+     (make-object color% red green blue)]
+    [(list (? byte? red) (? byte? green) (? byte? blue) (? (between/c 0 1) α))
+     (make-object color% red green blue α)]
+    [else #f]))
+
   (define (to-color c)
     (cond
       [(is-a? c color%) c]
@@ -531,7 +546,8 @@
          (unless (and (= 0 (send m get-r))
                       (= 0 (send m get-g))
                       (= 0 (send m get-b)))
-           (error 'register-color-scheme "expected a style delta with foreground-mult that is all zeros"))
+           (error 'register-color-scheme
+                  "expected a style delta with foreground-mult that is all zeros"))
          (let ([add (send c get-foreground-add)])
            (make-object color% 
              (send add get-r)
@@ -557,3 +573,459 @@
                      (send old set-delta-foreground color)
                      (preferences:set p old)])))
               color-scheme-colors))
+
+
+;                                                                                                 
+;                                                                                                 
+;                                                                                                 
+;                                                                                                 
+;                  ;;;                                 ;;;                                        
+;                  ;;;                                 ;;;                                        
+;    ;;;     ;;;   ;;;   ;;;   ;;; ;;    ;;;;    ;;;   ;;; ;;    ;;;;  ;;; ;; ;;;    ;;;;   ;;;;  
+;   ;;;;;   ;;;;;  ;;;  ;;;;;  ;;;;;    ;;; ;;  ;;;;;  ;;;;;;;  ;; ;;; ;;;;;;;;;;;  ;; ;;; ;;; ;; 
+;  ;;;  ;; ;;; ;;; ;;; ;;; ;;; ;;;      ;;;    ;;;  ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;    
+;  ;;;     ;;; ;;; ;;; ;;; ;;; ;;;       ;;;;  ;;;     ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;;;;;;  ;;;;  
+;  ;;;  ;; ;;; ;;; ;;; ;;; ;;; ;;;         ;;; ;;;  ;; ;;; ;;; ;;;     ;;; ;;; ;;; ;;;        ;;; 
+;   ;;;;;   ;;;;;  ;;;  ;;;;;  ;;;      ;; ;;;  ;;;;;  ;;; ;;;  ;;;;;; ;;; ;;; ;;;  ;;;;;; ;; ;;; 
+;    ;;;     ;;;   ;;;   ;;;   ;;;       ;;;;    ;;;   ;;; ;;;   ;;;;  ;;; ;;; ;;;   ;;;;   ;;;;  
+;                                                                                                 
+;                                                                                                 
+;                                                                                                 
+;                                                                                                 
+
+(define default-example
+  (string-append
+   "#lang racket   ; draw a graph of cos\n"
+   "(require plot) ; and deriv^3(cos)\n"
+   "(define ((deriv f) x)\n"
+   "  (/ (- (f x) (f (- x 0.001))) 0.001))\n"
+   "(define (thrice f) (lambda (x) (f (f (f x)))))\n"
+   "(plot (list (function ((thrice deriv) sin) -5 5)\n"
+   "            (function cos -5 5 #:color 'blue)))\n"
+   "\"an unclosed string is an error"))
+
+(struct color-scheme (name button-label white-on-black-base? mapping example))
+(define black-on-white-color-scheme-name 'classic)
+(define white-on-black-color-scheme-name 'white-on-black)
+(define known-color-schemes
+  ;; note:first item in this list must be the black-on-white color scheme
+  ;; and the second must the white-on-black color scheme
+  (list (color-scheme black-on-white-color-scheme-name
+                      (string-constant classic-color-scheme)
+                      #f (make-hash) default-example)
+        (color-scheme white-on-black-color-scheme-name
+                      (string-constant white-on-black-color-scheme)
+                      #t (make-hash) default-example)))
+
+(define color-change-callbacks (make-hash))
+
+(define known-color-names (set))
+(define known-style-names (set))
+
+(define-logger color-scheme)
+
+(define (register-info-based-color-schemes)
+  (log-color-scheme-info
+   "color-names: ~a\nstyle-names:\n~a\n" 
+   (sort (set->list known-color-names) symbol<?)
+   (sort (set->list known-style-names) symbol<?))
+  (for ([dir (in-list (find-relevant-directories '(framework:color-schemes)))])
+    (define info (get-info/full dir))
+    (when info
+      (define cs-info (info 'framework:color-schemes))
+      (cond
+        [(info-file-result-check? cs-info)
+         (for ([one-scheme (in-list cs-info)])
+           (define name (hash-ref one-scheme 'name 
+                                  (λ ()
+                                    (define d (path->module-path dir))
+                                    (if (path-string? d)
+                                        (format "~a" d)
+                                        (format "~s" d)))))
+           (define white-on-black-base? (hash-ref one-scheme 'white-on-black-base? #f))
+           (define mapping (hash-ref one-scheme 'colors '()))
+           (define example (hash-ref one-scheme 'example default-example))
+           (register-color-scheme (if (symbol? name)
+                                      (dynamic-string-constant name)
+                                      name)
+                                  white-on-black-base?
+                                  mapping
+                                  example))]
+        [else
+         (when cs-info
+           (log-color-scheme-warning
+            "expected something matching:\n~a\nfor framework:color-schemes in ~a, got\n~a"
+            (pretty-format (contract-name info-file-result-check?))
+            dir
+            (pretty-format cs-info)))]))))
+
+
+;; register-color-scheme : string boolean? (listof (cons/c symbol? (listof props)) -> void
+;; props = (or/c 'bold 'italic 'underline 
+;;              
+;; called based on the contents of info.rkt files
+(define (register-color-scheme scheme-name white-on-black-base? mapping example)
+  (define (good-line? line)
+    (or (set-member? known-color-names (car line))
+        (set-member? known-style-names (car line))))
+  (for ([x (in-list mapping)])
+    (unless (good-line? x)
+      (log-color-scheme-warning "unknown style/color name: ~s" x)))
+  (set! known-color-schemes
+        (append known-color-schemes
+                (list
+                 (color-scheme
+                  (if (symbol? scheme-name)
+                      scheme-name
+                      (string->symbol scheme-name))
+                  (if (symbol? scheme-name)
+                      (dynamic-string-constant scheme-name)
+                      scheme-name)
+                  white-on-black-base?
+                  (make-hash
+                   (for/list ([line (in-list mapping)]
+                              #:when (good-line? line))
+                     (define name (car line))
+                     (cons name
+                           (cond
+                             [(set-member? known-color-names name)
+                              (props->color (cdr line))]
+                             [(set-member? known-style-names name)
+                              (props->style-delta (cdr line))]))))
+                  example)))))
+
+(define valid-props? 
+  (listof (or/c 'bold 'italic 'underline
+                (vector/c byte? byte? byte? #:flat? #t)
+                (vector/c byte? byte? byte? (between/c 0.0 1.0) #:flat? #t))))
+
+(define (valid-key-values? h)
+  (for/or ([(k v) (in-hash h)])
+    (cond
+      [(equal? k 'name) (or (string? v) (symbol? v))]
+      [(equal? k 'white-on-black-base?) (boolean? v)]
+      [(equal? k 'colors) ((listof (cons/c symbol? valid-props?)) v)]
+      [(equal? k 'example) (string? v)]
+      [else 
+       ;; don't care about other keys, as they'll be ignored
+       #t])))
+
+(define info-file-result-check?
+  (listof (and/c hash?
+                 immutable?
+                 valid-key-values?)))
+
+(define (props->color line)
+  (or (for/or ([v (in-list line)])
+        (and (vector? v)
+             (vec->color v)))
+      (vec->color #'(0 0 0))))
+
+(define (props->style-delta line)
+  (define sd (new style-delta%))
+  (for ([prop (in-list line)])
+    (match prop
+      [`bold (send sd set-delta 'change-bold)]
+      [`italic (send sd set-delta 'change-italic)]
+      [`underline (send sd set-delta 'change-underline #t)]
+      [else (send sd set-delta-foreground (vec->color prop))]))
+  sd)
+
+(define (vec->color v)
+  (make-object color% 
+    (vector-ref v 0)
+    (vector-ref v 1)
+    (vector-ref v 2)
+    (if (= (vector-length v) 4)
+        (vector-ref v 3)
+        1.0)))
+
+;; returns the user's preferred color, wrt to the current color scheme
+(define (lookup-in-color-scheme color-name)
+  (lookup-in-color-scheme/given-mapping 
+   color-name
+   (preferences:get (color-scheme-entry-name->pref-name color-name))
+   (get-current-color-scheme)))
+
+(define (lookup-in-color-scheme/given-mapping color-name table a-color-scheme)
+  (cond
+    ;; check if the user adjusted the color
+    [(hash-ref table (color-scheme-name a-color-scheme) #f)
+     =>
+     values]
+    ;; check if the color scheme has that mapping
+    [(hash-ref (color-scheme-mapping a-color-scheme)
+               color-name
+               #f)
+     => values]
+    [else
+     ;; fall back to either the white-on-black or the black-on-white color scheme
+     (define fallback-color-scheme
+       (lookup-color-scheme
+        (if (color-scheme-white-on-black-base? a-color-scheme)
+            white-on-black-color-scheme-name
+            black-on-white-color-scheme-name)))
+     (hash-ref (color-scheme-mapping fallback-color-scheme)
+               color-name)]))
+
+;; set-color : symbol (or/c string? (is-a?/c color%) (is-a?/c style-delta%)) -> void
+(define (set-in-color-scheme color-name clr/sd)
+  (define table (preferences:get (color-scheme-entry-name->pref-name color-name)))
+  (define current-color-scheme (get-current-color-scheme))
+  (define scheme-name (color-scheme-name current-color-scheme))
+  (define new-table
+    (cond
+      [(set-member? known-style-names color-name)
+       ;; it would be good to be able to use hash-remove here when 
+       (hash-set table scheme-name clr/sd)]
+      [else
+       (define color (->color-object clr/sd))
+       (define default 
+         (hash-ref (color-scheme-mapping current-color-scheme)
+                   color-name
+                   #f))
+       (cond
+         [(and default (same-color? color default))
+          (hash-remove table scheme-name)]
+         [else
+          (hash-set table scheme-name color)])]))
+  (preferences:set (color-scheme-entry-name->pref-name color-name) new-table))
+
+(define (->color-object clr)
+  (if (string? clr)
+      (send the-color-database find-color clr)
+      clr))
+
+(define (same-color? c1 c2)
+  (and (= (send c1 red) (send c2 red))
+       (= (send c1 green) (send c2 green))
+       (= (send c1 blue) (send c2 blue))
+       (= (send c1 alpha) (send c2 alpha))))
+
+(define (get-current-color-scheme)
+  ;; if pref not recognized, return white-on-black color scheme
+  ;; so that if some color scheme goes away, we have
+  ;; some reasonable backup plan (and, if it comes back
+  ;; we don't lose the prefs)
+  (define pref-val (preferences:get 'framework:color-scheme))
+  (define found-color-scheme (lookup-color-scheme pref-val))
+  (cond
+    [found-color-scheme found-color-scheme]
+    [else (car known-color-schemes)]))
+
+;; string -> (or/c #f color-scheme?)
+(define (lookup-color-scheme name)
+  (for/or ([known-color-scheme (in-list known-color-schemes)])
+    (and (equal? name (color-scheme-name known-color-scheme))
+         known-color-scheme)))
+
+(define (set-current-color-scheme name)
+  (define color-scheme
+    (or (for/or ([known-color-scheme (in-list known-color-schemes)])
+          (and (equal? name (color-scheme-name known-color-scheme))
+               known-color-scheme))
+        (car known-color-schemes)))
+  (unless (equal? (color-scheme-name color-scheme)
+                  (color-scheme-name (get-current-color-scheme)))
+    (preferences:set 'framework:color-scheme (color-scheme-name color-scheme))
+    (define old-wob (preferences:get 'framework:white-on-black?))
+    (define new-wob (color-scheme-white-on-black-base? color-scheme))
+    (unless (equal? old-wob new-wob)
+      (preferences:set 'framework:white-on-black? new-wob)
+      (if new-wob
+          (white-on-black)
+          (black-on-white)))
+    (for ([(color-name fns) (in-hash color-change-callbacks)])
+      (for ([fn/b (in-list fns)])
+        (define fn (if (weak-box? fn/b) (weak-box-value fn/b) fn/b))
+        (when fn
+          (fn (lookup-in-color-scheme color-name)))))))
+
+(define (get-available-color-schemes) 
+  (for/list ([(name a-color-scheme) (in-hash known-color-schemes)])
+    name))
+
+;; symbol (-> (or/c (is-a?/c style-delta%) (is-a?/c color%)) void) -> void
+(define (register-color-scheme-entry-change-callback color fn [weak? #f])
+  (define wb/f (if weak? (make-weak-box fn) fn))
+  ;; so we know which callbacks to call when a color scheme change happens
+  (hash-set! color-change-callbacks 
+             color
+             (cons wb/f
+                   (remove-gones (hash-ref color-change-callbacks color '()))))
+  ;; so that individual color changes in a given scheme get callbacks
+  (define remover
+    (preferences:add-callback
+     (color-scheme-entry-name->pref-name color)
+     (λ (pref ht)
+       (define fn
+         (cond
+           [(weak-box? wb/f)
+            (define fn (weak-box-value wb/f))
+            (unless fn (remover))
+            fn]
+           [else wb/f]))
+       (when fn
+         (fn (lookup-in-color-scheme/given-mapping 
+              color
+              ht
+              (get-current-color-scheme)))))))
+  (void))
+
+(define (remove-gones lst)
+  (for/list ([x (in-list lst)]
+             #:when (or (not (weak-box? x))
+                        (weak-box-value x)))
+    x))
+
+(define (known-color-scheme-name? n) 
+  (or (set-member? known-color-names n) 
+      (set-member? known-style-names n)))
+
+(define (color-scheme-style-name? n)
+  (set-member? known-style-names n))
+
+(define (color-scheme-entry-name->pref-name sym)
+  (string->symbol (format "color-scheme-entry:~a" sym)))
+
+(define name->style-name (make-hash))
+
+(define (add-color-scheme-entry name _b-o-w-color _w-o-b-color 
+                                #:style [style-name #f]
+                                #:bold? [bold? #f]
+                                #:underline? [underline? #f]
+                                #:italic? [italic? #f]
+                                #:background [background #f])
+  (define b-o-w-color (->color-object _b-o-w-color))
+  (define w-o-b-color (->color-object _w-o-b-color))
+  (cond
+    [style-name
+     (set! known-style-names (set-add known-style-names name))
+     (hash-set! name->style-name name style-name)]
+    [else
+     (set! known-color-names (set-add known-color-names name))])
+  (define (update-color scheme-name color)
+    (hash-set! (color-scheme-mapping (lookup-color-scheme scheme-name))
+               name
+               (if style-name
+                   (make-style-delta color bold? underline? italic? #:background background)
+                   color)))
+  (update-color white-on-black-color-scheme-name w-o-b-color)
+  (update-color black-on-white-color-scheme-name b-o-w-color)
+  (preferences:set-default (color-scheme-entry-name->pref-name name)
+                           (hash)
+                           (hash/c symbol?
+                                   (if style-name 
+                                       (is-a?/c style-delta%)
+                                       (is-a?/c color%))
+                                   #:immutable #t))
+  (preferences:set-un/marshall 
+   (color-scheme-entry-name->pref-name name)
+   (λ (h)
+     (for/hash ([(k v) (in-hash h)])
+       (values k
+               (if style-name
+                   (marshall-style-delta v)
+                   (vector (send v red) (send v green) (send v blue) (send v alpha))))))
+   (λ (val)
+     (cond
+       [(and (list? val) (= (length val) (length style-delta-get/set)))
+        ;; old style prefs; check to see if this user
+        ;; was using the white on black or black on white and 
+        ;; build the corresponding new pref
+        (hash (if (preferences:get 'framework:white-on-black?)
+                  white-on-black-color-scheme-name
+                  black-on-white-color-scheme-name)
+              (unmarshall-style-delta val))]
+       [(unmarshall-color val)
+        => 
+        (λ (clr)
+          ;; old color prefs; as above
+          (hash (if (preferences:get 'framework:white-on-black?)
+                    white-on-black-color-scheme-name
+                    black-on-white-color-scheme-name)
+                clr))]
+       [(hash? val)
+        ;; this may return a bogus hash, but the preferesnces system will check
+        ;; and revert this to the default pref in that case
+        (for/hash ([(k v) (in-hash val)])
+          (values 
+           k 
+           (if style-name
+               (unmarshall-style-delta v)
+               (and (vector? v)
+                    (= (vector-length v) 4)
+                    (make-object color% 
+                      (vector-ref v 0) (vector-ref v 1) 
+                      (vector-ref v 2) (vector-ref v 3))))))]
+       [else #f])))
+  
+  (when style-name
+    (register-color-scheme-entry-change-callback
+     name
+     (λ (sd)
+       (editor:set-standard-style-list-delta style-name sd)))
+    (editor:set-standard-style-list-delta style-name (lookup-in-color-scheme name))))
+
+(define (add-color-scheme-preferences-panel)
+  (preferences:add-panel
+   (list (string-constant preferences-colors)
+         (string-constant color-schemes))
+   (λ (parent)
+     (define vp 
+       (new vertical-panel% 
+            [parent parent]
+            [style '(auto-vscroll)]))
+     (define buttons
+       (for/list ([color-scheme (in-list known-color-schemes)])
+         (define hp (new horizontal-panel% 
+                         [parent vp]
+                         [alignment '(left top)]
+                         [stretchable-height #t]))
+         (define t (new racket:text%))
+         (define str (color-scheme-example color-scheme))
+         (send t insert str)
+         (define ec (new editor-canvas% 
+                         [parent hp]
+                         [style '(auto-hscroll no-vscroll)]
+                         [editor t]))
+         (send ec set-canvas-background
+               (send the-color-database find-color
+                     (if (color-scheme-white-on-black-base? color-scheme)
+                         "black"
+                         "white")))
+         (send t set-style-list (color-scheme->style-list color-scheme))
+         (send ec set-line-count (+ 1 (for/sum ([c (in-string str)])
+                                        (if (equal? c #\newline)
+                                            1
+                                            0))))
+         (new button%
+              [label (color-scheme-button-label color-scheme)]
+              [parent hp]
+              [callback (λ (x y) 
+                          (set-current-color-scheme
+                           (color-scheme-name color-scheme)))])))
+     (define wid (apply max (map (λ (x) (send x get-width)) buttons)))
+     (for ([b (in-list buttons)])
+       (send b min-width wid)))))
+
+(define (color-scheme->style-list color-scheme)
+  (define style-list (new style-list%))
+  
+  (define standard-delta (make-object style-delta% 'change-normal))
+  (send standard-delta set-delta 'change-family 'modern)
+  (send standard-delta set-size-mult 0)
+  (send standard-delta set-size-add (editor:get-current-preferred-font-size))
+  (send style-list new-named-style "Standard"
+        (send style-list find-or-create-style
+              (send style-list basic-style)
+              standard-delta))
+  (for ([name (in-set known-style-names)])
+    (define delta
+      (lookup-in-color-scheme/given-mapping name (hash) color-scheme))
+    (send style-list new-named-style
+          (hash-ref name->style-name name)
+          (send style-list find-or-create-style
+                (send style-list find-named-style "Standard")
+                delta)))
+  style-list)
diff --git a/pkgs/gui-pkgs/gui-lib/framework/private/color.rkt b/pkgs/gui-pkgs/gui-lib/framework/private/color.rkt
index 01d54b9c22..2f949ebce1 100644
--- a/pkgs/gui-pkgs/gui-lib/framework/private/color.rkt
+++ b/pkgs/gui-pkgs/gui-lib/framework/private/color.rkt
@@ -678,7 +678,8 @@ added get-regions
     (define clear-old-locations void)
     
     (define mismatch-color (make-object color% "PINK"))
-    (define/private (get-match-color) (preferences:get 'framework:paren-match-color))
+    (define/private (get-match-color) 
+      (color-prefs:lookup-in-color-scheme 'framework:paren-match-color))
     
     
     ;; higlight : number number number (or/c color any)
@@ -1232,7 +1233,7 @@ added get-regions
                  'low))))
   (cons (list 'basic-grey
               (string-constant paren-color-basic-grey)
-              (vector (preferences:get 'framework:paren-match-color))
+              (vector (color-prefs:lookup-in-color-scheme 'framework:paren-match-color))
               'high)
         parenthesis-color-table))
 
diff --git a/pkgs/gui-pkgs/gui-lib/framework/private/main.rkt b/pkgs/gui-pkgs/gui-lib/framework/private/main.rkt
index 4d5c7a2f60..d80fc8624f 100644
--- a/pkgs/gui-pkgs/gui-lib/framework/private/main.rkt
+++ b/pkgs/gui-pkgs/gui-lib/framework/private/main.rkt
@@ -25,6 +25,8 @@
 
 (application-preferences-handler (λ () (preferences:show-dialog)))
 
+(preferences:set-default 'framework:color-scheme 'classic symbol?)
+
 (preferences:set-default 'framework:column-guide-width
                          '(#f 102)
                          (list/c boolean? (and/c exact-integer? (>=/c 2))))
@@ -193,7 +195,7 @@
 (preferences:set-default 'framework:case-sensitive-search?
                          #f
                          boolean?)
-(color-prefs:set-default/color-scheme 'framework:basic-canvas-background "white" "black")
+(color-prefs:add-color-scheme-entry 'framework:basic-canvas-background "white" "black")
 
 (preferences:set-default 'framework:special-meta-key #f boolean?)
 (preferences:add-callback 'framework:special-meta-key (λ (p v) (map-command-as-meta-key v)))
@@ -250,26 +252,26 @@
            (- (* 7/8 256) 1))])
   (define default-color (make-object color% 0 0 0 (- 1. (/ gray-level 255))))
   (define w-o-b-default-color (make-object color% 255 255 255 (/ 50 255)))
-  (color-prefs:set-default/color-scheme 'framework:paren-match-color
-                                        default-color
-                                        w-o-b-default-color)
+  (color-prefs:add-color-scheme-entry 'framework:paren-match-color
+                                      default-color
+                                      w-o-b-default-color)
   
   ;; when the preference is currently set to the old color,
   ;; then just update it to the new one (if someone really
   ;; wants the old default, they can still have a color that is
   ;; off by one from the old default which should be ok)
-  (define current-color (preferences:get 'framework:paren-match-color))
+  (define current-color (color-prefs:lookup-in-color-scheme 'framework:paren-match-color))
   (cond
     [(and (= (send current-color red) gray-level)
           (= (send current-color green) gray-level)
           (= (send current-color blue) gray-level)
           (= (send current-color alpha) 1.0))
-     (preferences:set 'framework:paren-match-color default-color)]
+     (color-prefs:set-in-color-scheme 'framework:paren-match-color default-color)]
     [(and (= (send current-color red) 50)
           (= (send current-color green) 50)
           (= (send current-color blue) 50)
           (= (send current-color alpha) 1.0))
-     (preferences:set 'framework:paren-match-color w-o-b-default-color)]))
+     (color-prefs:set-in-color-scheme 'framework:paren-match-color w-o-b-default-color)]))
 
 (preferences:set-default 'framework:recently-opened-files/pos 
                          null 
@@ -494,34 +496,36 @@
 (preferences:set-default 'framework:file-dialogs 'std
                          (λ (x) (and (memq x '(common std)) #t)))
 
-(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-preference
-               (racket:short-sym->pref-name sym)
-               (racket:short-sym->style-name sym)
-               color
-               white-on-black-color)))
-          (racket:get-color-prefs-table)
-          (racket:get-white-on-black-color-prefs-table))
+(for ([line (in-list (racket:get-color-prefs-table))]
+      [white-on-black-line (in-list (racket:get-white-on-black-color-prefs-table))])
+  (define sym (car line))
+  (define color (cadr line))
+  (define white-on-black-color (cadr white-on-black-line))
+  (color-prefs:add-color-scheme-entry (racket:short-sym->pref-name sym)
+                                      #:style (racket:short-sym->style-name sym)
+                                      color
+                                      white-on-black-color))
+  
 (preferences:set-default 'framework:coloring-active #t boolean?)
 
-(color-prefs:set-default/color-scheme 'framework:default-text-color "black" "white")
-(preferences:add-callback 'framework:basic-canvas-background
-                          (λ (p v)
-                            (editor:set-default-font-color
-                             (preferences:get 'framework:default-text-color)
-                             v)))
-(preferences:add-callback 'framework:default-text-color
-                          (λ (p v)
-                            (editor:set-default-font-color 
-                             v 
-                             (preferences:get 'framework:basic-canvas-background))))
-(editor:set-default-font-color (preferences:get 'framework:default-text-color)
-                               (preferences:get 'framework:basic-canvas-background))
+(color-prefs:add-color-scheme-entry 'framework:default-text-color "black" "white")
+(color-prefs:register-color-scheme-entry-change-callback
+ 'framework:basic-canvas-background
+ (λ (v)
+   (editor:set-default-font-color
+    (color-prefs:lookup-in-color-scheme 'framework:default-text-color)
+    v)))
+(color-prefs:register-color-scheme-entry-change-callback
+ 'framework:default-text-color
+ (λ (v)
+   (editor:set-default-font-color 
+    v 
+    (color-prefs:lookup-in-color-scheme 'framework:basic-canvas-background))))
+(editor:set-default-font-color 
+ (color-prefs:lookup-in-color-scheme 'framework:default-text-color)
+ (color-prefs:lookup-in-color-scheme 'framework:basic-canvas-background))
 
-(color-prefs:set-default/color-scheme 'framework:misspelled-text-color "black" "white")
+(color-prefs:add-color-scheme-entry 'framework:misspelled-text-color "black" "white")
 
 (color-prefs:set-default/color-scheme 'framework:delegatee-overview-color
                                       "light blue"
@@ -545,11 +549,11 @@
          (send style get-delta delta)
          (send delta set-delta-foreground v)
          (send style set-delta delta))])
-  (preferences:add-callback
+  (color-prefs:register-color-scheme-entry-change-callback
    'framework:misspelled-text-color
-   (λ (p v) (update-style-list v)))
+   (λ (v) (update-style-list v)))
   (update-style-list 
-   (preferences:get 'framework:misspelled-text-color)))
+   (color-prefs:lookup-in-color-scheme 'framework:misspelled-text-color)))
 
 ;; groups
 
diff --git a/pkgs/gui-pkgs/gui-lib/framework/private/sig.rkt b/pkgs/gui-pkgs/gui-lib/framework/private/sig.rkt
index 0c156b6d6f..821b577bea 100644
--- a/pkgs/gui-pkgs/gui-lib/framework/private/sig.rkt
+++ b/pkgs/gui-pkgs/gui-lib/framework/private/sig.rkt
@@ -429,7 +429,18 @@
      unmarshall-style-delta
      set-default/color-scheme
      white-on-black
-     black-on-white))
+     black-on-white
+     
+     add-color-scheme-preferences-panel
+     set-current-color-scheme
+     get-current-color-scheme
+     known-color-scheme-name?
+     color-scheme-style-name?
+     lookup-in-color-scheme
+     set-in-color-scheme
+     register-color-scheme-entry-change-callback
+     add-color-scheme-entry
+     register-info-based-color-schemes))
   
   (define-signature racket-class^
     (text<%>
diff --git a/pkgs/htdp-pkgs/htdp-lib/lang/htdp-langs.rkt b/pkgs/htdp-pkgs/htdp-lib/lang/htdp-langs.rkt
index f2a1cbf25f..fc3f21a91c 100644
--- a/pkgs/htdp-pkgs/htdp-lib/lang/htdp-langs.rkt
+++ b/pkgs/htdp-pkgs/htdp-lib/lang/htdp-langs.rkt
@@ -1332,9 +1332,9 @@
            (abbreviate-cons-as-list #t)
            (allow-sharing? #f)
            (reader-module '(lib "htdp-beginner-abbr-reader.ss" "lang"))
-	   (stepper:supported #t)
+           (stepper:supported #t)
            (stepper:enable-let-lifting #t)
-	   (stepper:show-lambdas-as-lambdas #f)))
+           (stepper:show-lambdas-as-lambdas #f)))
         
         (add-htdp-language
          (instantiate htdp-language% ()
@@ -1352,25 +1352,24 @@
            (allow-sharing? #f)
            (accept-quasiquote? #f)
            (reader-module '(lib "htdp-beginner-reader.ss" "lang"))
-	   (stepper:supported #t)
+           (stepper:supported #t)
            (stepper:enable-let-lifting #t)
-	   (stepper:show-lambdas-as-lambdas #f))))
+           (stepper:show-lambdas-as-lambdas #f))))
       
       (define test-coverage-on-style-name "plt:htdp:test-coverage-on")
       (define test-coverage-off-style-name "plt:htdp:test-coverage-off")
       (define test-coverage-on-style-pref (string->symbol test-coverage-on-style-name))
       (define test-coverage-off-style-pref (string->symbol test-coverage-off-style-name))
       
-      (color-prefs:register-color-preference test-coverage-on-style-pref
-                                             test-coverage-on-style-name
-                                             (send the-color-database find-color "black")
-                                             (send the-color-database find-color "white"))
-      (color-prefs:register-color-preference test-coverage-off-style-pref
-                                             test-coverage-off-style-name
-                                             (send the-color-database find-color "orange")
-                                             (send the-color-database find-color "indianred")
-                                             #:background 
-                                             (send the-color-database find-color "black"))
+      (color-prefs:add-color-scheme-entry test-coverage-on-style-pref
+                                          #:style test-coverage-on-style-name
+                                          "black"
+                                          "white")
+      (color-prefs:add-color-scheme-entry test-coverage-off-style-pref
+                                          #:style test-coverage-off-style-name
+                                          "orange"
+                                          "indianred"
+                                          #:background "black")
       (color-prefs:add-to-preferences-panel 
        "HtDP Languages"
        (λ (parent)
@@ -1382,27 +1381,4 @@
                                                   test-coverage-off-style-pref
                                                   test-coverage-off-style-name
                                                   (string-constant test-coverage-off)
-                                                  #:background? #t)))
-      
-      (define (update-sds white-on-black?)
-        (define sl (editor:get-standard-style-list))
-        (define on-s (send sl find-named-style test-coverage-on-style-name))
-        (define off-s (send sl find-named-style test-coverage-off-style-name))
-        (define on-sd (make-object style-delta%))
-        (define off-sd (make-object style-delta%))
-        (send on-s get-delta on-sd)
-        (send off-s get-delta off-sd)
-        (cond
-          [white-on-black?
-           (send on-sd set-delta-foreground "white")
-           (send off-sd set-delta-foreground "indianred")
-           (send off-sd set-delta-background "black")]
-          [else
-           (send on-sd set-delta-foreground "black")
-           (send off-sd set-delta-foreground "orange")
-           (send off-sd set-delta-background "black")])
-        (preferences:set test-coverage-on-style-pref on-sd)
-        (preferences:set test-coverage-off-style-pref off-sd))
-      
-      (preferences:add-callback 'framework:white-on-black?
-                                (λ (p v) (update-sds v)))))
+                                                  #:background? #t)))))
diff --git a/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt b/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt
index 57e3764081..f832875130 100644
--- a/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt
+++ b/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt
@@ -548,13 +548,15 @@ please adhere to these guidelines:
  (hide-column-width-guide "Hide Column Width Guide for Files with ~a Columns")
  (show-column-width-guide "Show Column Width Guide at ~a Columns") ;; filled with a number > 2
  (limit-interactions-size "Limit interactions size")
- (background-color "Background Color")
+ (background-color "Background") ;; this is in the color section already, so shorten the name a little
  (default-text-color "Default text") ;; used for configuring colors, but doesn't need the word "color"
  (choose-a-background-color "Please choose a background color")
  (revert-to-defaults "Revert to Defaults")
  (undo-changes "Undo Changes and Close") ;; used in the preferences dialog to undo preference changes
   
-  (black-on-white-color-scheme "Black on White") ;; these two appear in the color preferences dialog on butttons
+  (color-schemes "Color Schemes") ;; the label in the preferences dialog for the color scheme panel
+  (classic-color-scheme "Classic") ;; formerly called 'black on white'
+  (modern-color-scheme "Modern")   ;; an attempt to be more color-blind friendly
   (white-on-black-color-scheme "White on Black") ;; clicking the buttons changes the color schemes to some defaults that've been set up.
   
   (add-spacing-between-lines "Add one pixel of extra space between lines")