From 4a5976a827a0033dc896d73ec5e44736a24e2d80 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 1 Feb 2007 23:55:20 +0000
Subject: [PATCH] separated preferences library out to be used by mz

svn: r5537

original commit: 13110a2113d1a8e2174e7e381809cb90916d18bf
---
 collects/framework/framework.ss           | 135 +--------
 collects/framework/private/autosave.ss    |   8 +-
 collects/framework/private/canvas.ss      |   4 +-
 collects/framework/private/color-prefs.ss |   2 +-
 collects/framework/private/color.ss       |   9 +-
 collects/framework/private/editor.ss      |   4 +-
 collects/framework/private/exit.ss        |  11 +-
 collects/framework/private/finder.ss      |   5 +-
 collects/framework/private/frame.ss       |   3 +-
 collects/framework/private/group.ss       |   4 +-
 collects/framework/private/handler.ss     |   4 +-
 collects/framework/private/keymap.ss      |   2 +-
 collects/framework/private/main.ss        |  11 +-
 collects/framework/private/menu.ss        |   6 +-
 collects/framework/private/number-snip.ss |   4 +-
 collects/framework/private/preferences.ss | 354 ++--------------------
 collects/framework/private/scheme.ss      |   6 +-
 collects/framework/private/sig.ss         |  16 +-
 collects/framework/private/text.ss        |   4 +-
 19 files changed, 75 insertions(+), 517 deletions(-)

diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss
index 2261f16a..e4146132 100644
--- a/collects/framework/framework.ss
+++ b/collects/framework/framework.ss
@@ -6,6 +6,7 @@
            (lib "mred.ss" "mred")
            (lib "class.ss")
            
+           "preferences.ss"
            "test.ss"
            "gui-utils.ss"
            "decorated-editor-snip.ss"
@@ -19,7 +20,6 @@
    (prefix application: framework:application-class^)
    (prefix version: framework:version-class^)
    (prefix color-model: framework:color-model-class^)
-   (prefix exn: framework:exn-class^)
    (prefix mode: framework:mode-class^)
    (prefix exit: framework:exit-class^)
    (prefix menu: framework:menu-class^)
@@ -46,11 +46,9 @@
 
   (provide (all-from "test.ss")
            (all-from "gui-utils.ss")
+           (all-from "preferences.ss")
            (all-from "decorated-editor-snip.ss"))
 
-  (provide exn:struct:unknown-preference
-           exn:struct:exn)
-
   (define-syntax (provide/contract/docs stx)
     (syntax-case stx ()
       [(_ (name contract docs ...) ...)
@@ -107,23 +105,6 @@
     "@flink version:add-spec %"
     ".")
 
-   (exn:make-exn
-    (string? continuation-mark-set? . -> . exn?)
-    (message continuation-marks)
-    "Creates a framework exception.")
-   (exn:exn?
-    (any/c . -> . boolean?)
-    (exn)
-    "Tests if a value is a framework exception.")
-   (exn:make-unknown-preference 
-    (string? continuation-mark-set? . -> . exn:unknown-preference?)
-    (message continuation-marks)
-    "Creates an unknown preference exception.")
-   (exn:unknown-preference? 
-    (any/c . -> . boolean?)
-    (exn)
-    "Determines if a value is an unknown preference exn.")
-
    (application:current-app-name
     (case-> (-> string?)
             (string? . -> . void?))
@@ -137,116 +118,6 @@
     "the second case in the case-lambda sets"
     "the name of the application to \\var{name}.")
 
-   (preferences:get
-    (symbol? . -> . any/c)
-    (symbol)
-    "See also"
-    "@flink preferences:set-default %"
-    "."
-    ""
-    "\\rawscm{preferences:get} returns the value for the preference"
-    "\\var{symbol}. It raises"
-    "\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}"
-    "if the preference's default has not been set.")
-   (preferences:set
-    (symbol? any/c . -> . void?)
-    (symbol value)
-    "See also"
-    "@flink preferences:set-default %"
-    "."
-    ""
-    "\\rawscm{preferences:set-preference} sets the preference"
-    "\\var{symbol} to \\var{value}. This should be called when the"
-    "users requests a change to a preference."
-    ""
-    "This function immediately writes the preference value to disk."
-    ""
-    "It raises"
-    "\\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))
-           (boolean?)
-           (-> void?))
-    ((p f)
-     ((weak? #f)))
-    "This function adds a callback which is called with a symbol naming a"
-    "preference and it's value, when the preference changes."
-    "\\rawscm{preferences:add-callback} returns a thunk, which when"
-    "invoked, removes the callback from this preference."
-    ""
-    "If \\var{weak?} is true, the preferences system will only hold on to"
-    "the callback weakly."
-    ""
-    "The callbacks will be called in the order in which they were added."
-    ""
-    "If you are adding a callback for a preference that requires"
-    "marshalling and unmarshalling, you must set the marshalling and"
-    "unmarshalling functions by calling"
-    "\\iscmprocedure{preferences:set-un/marshall} before adding a callback."
-    ""
-    "This function raises"
-    "\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}"
-    "if the preference has not been set.")
-   (preferences:set-default
-    (symbol? any/c (any/c . -> . any) . -> . void?)
-    (symbol value test)
-    "This function must be called every time your application starts up, before any call to"
-    "@flink preferences:get %"
-    ", "
-    "@flink preferences:set"
-    "(for any given preference)."
-    ""
-    "If you use"
-    "@flink preferences:set-un/marshall %"
-    ", you must call this function before calling it."
-    ""
-    "This sets the default value of the preference \\var{symbol} to"
-    "\\var{value}. If the user has chosen a different setting,"
-    "the user's setting"
-    "will take precedence over the default value."
-    ""
-    "The last argument, \\var{test} is used as a safeguard. That function is"
-    "called to determine if a preference read in from a file is a valid"
-    "preference. If \\var{test} returns \\rawscm{\\#t}, then the preference is"
-    "treated as valid. If \\var{test} returns \\rawscm{\\#f} then the default is"
-    "used.")
-   (preferences:set-un/marshall
-    (symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?)
-    (symbol marshall unmarshall)
-    "\\rawscm{preference:set-un/marshall} is used to specify marshalling and"
-    "unmarshalling functions for the preference"
-    "\\var{symbol}. \\var{marshall} will be called when the users saves their"
-    "preferences to turn the preference value for \\var{symbol} into a"
-    "printable value. \\var{unmarshall} will be called when the user's"
-    "preferences are read from the file to transform the printable value"
-    "into it's internal representation. If \\rawscm{preference:set-un/marshall}"
-    "is never called for a particular preference, the values of that"
-    "preference are assumed to be printable."
-    ""
-    "If the unmarshalling function returns a value that does not meet the"
-    "guard passed to "
-    "@flink preferences:set-default"
-    "for this preference, the default value is used."
-    ""
-    "The \\var{marshall} function might be called with any value returned"
-    "from \\scheme{read} and it must not raise an error (although it"
-    "can return arbitrary results if it gets bad input). This might"
-    "happen when the preferences file becomes corrupted, or is edited"
-    "by hand."
-    ""
-    "\\rawscm{preference:set-un/marshall} must be called before calling"
-    "@flink preferences:get %"
-    ", "
-    "@flink preferences:set %"
-    ".")
-   
-   (preferences:restore-defaults
-    (-> void?)
-    ()
-    "\\rawscm{(preferences:restore-defaults)} restores the users's configuration to the"
-    "default preferences.")
-
    (preferences:add-panel
     ((or/c string? (cons/c string? (listof string?)))
      ((is-a?/c area-container-window<%>) 
@@ -279,7 +150,7 @@
    "\\var{f} is expected to add a new child panel to it and add"
    "whatever preferences configuration controls it wants to that"
    "panel. Then, \\var{f}'s should return the panel it added.")
-
+   
    (preferences:add-editor-checkbox-panel
     (-> void?)
     ()
diff --git a/collects/framework/private/autosave.ss b/collects/framework/private/autosave.ss
index 7aba4fdc..a68825fe 100644
--- a/collects/framework/private/autosave.ss
+++ b/collects/framework/private/autosave.ss
@@ -4,15 +4,13 @@
            (lib "file.ss")
 	   "sig.ss"
 	   "../gui-utils.ss"
-	   (lib "mred-sig.ss" "mred")
-           (lib "mred.ss" "mred") ;; remove this!
+           "../preferences.ss"
+           (lib "mred-sig.ss" "mred")
            (lib "list.ss")
-           (lib "string-constant.ss" "string-constants")
-           (lib "unit.ss"))
+           (lib "string-constant.ss" "string-constants"))
   
   (import mred^
           [prefix exit: framework:exit^]
-          [prefix preferences: framework:preferences^]
           [prefix frame: framework:frame^]
           [prefix scheme: framework:scheme^]
           [prefix editor: framework:editor^]
diff --git a/collects/framework/private/canvas.ss b/collects/framework/private/canvas.ss
index f3a1ed39..7551357e 100644
--- a/collects/framework/private/canvas.ss
+++ b/collects/framework/private/canvas.ss
@@ -1,10 +1,10 @@
 (module canvas (lib "a-unit.ss")
   (require (lib "class.ss")
 	   "sig.ss"
-	   (lib "mred-sig.ss" "mred"))
+	   "../preferences.ss"
+           (lib "mred-sig.ss" "mred"))
 
   (import mred^
-          [prefix preferences: framework:preferences^]
           [prefix frame: framework:frame^]
           [prefix text: framework:text^])
 
diff --git a/collects/framework/private/color-prefs.ss b/collects/framework/private/color-prefs.ss
index 72e8e6ca..57e6921a 100644
--- a/collects/framework/private/color-prefs.ss
+++ b/collects/framework/private/color-prefs.ss
@@ -1,9 +1,9 @@
 (module color-prefs (lib "a-unit.ss")
   (require (lib "class.ss")
-           (lib "unit.ss")
            (lib "etc.ss")
            (lib "mred.ss" "mred")
            (lib "string-constant.ss" "string-constants")
+           "../preferences.ss"
            "sig.ss")
   
   (import [prefix preferences: framework:preferences^]
diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss
index 23d3ff15..7bb9a02f 100644
--- a/collects/framework/private/color.ss
+++ b/collects/framework/private/color.ss
@@ -1,16 +1,15 @@
 (module color (lib "a-unit.ss")
   (require (lib "class.ss")
-           (lib "etc.ss")
-	   (lib "thread.ss")
+           (lib "thread.ss")
            (lib "mred.ss" "mred")
+           (lib "etc.ss")
            (lib "token-tree.ss" "syntax-color")
            (lib "paren-tree.ss" "syntax-color")
            (lib "default-lexer.ss" "syntax-color")
-           (lib "unit.ss")
+           "../preferences.ss"
            "sig.ss")
 
-  (import [prefix preferences: framework:preferences^]
-          [prefix icon: framework:icon^]
+  (import [prefix icon: framework:icon^]
           [prefix mode: framework:mode^]
           [prefix text: framework:text^]
           [prefix color-prefs: framework:color-prefs^]
diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss
index 19315ff5..3c47fb15 100644
--- a/collects/framework/private/editor.ss
+++ b/collects/framework/private/editor.ss
@@ -3,7 +3,8 @@
   (require (lib "class.ss")
            (lib "string-constant.ss" "string-constants")
 	   "sig.ss"
-	   "../gui-utils.ss"
+	   "../preferences.ss"
+           "../gui-utils.ss"
            (lib "etc.ss")
 	   (lib "mred-sig.ss" "mred")
 	   (lib "file.ss"))
@@ -14,7 +15,6 @@
           [prefix path-utils: framework:path-utils^]
           [prefix keymap: framework:keymap^]
           [prefix icon: framework:icon^]
-          [prefix preferences: framework:preferences^]
           [prefix text: framework:text^]
           [prefix pasteboard: framework:pasteboard^]
           [prefix frame: framework:frame^]
diff --git a/collects/framework/private/exit.ss b/collects/framework/private/exit.ss
index 99b7db4e..c49ad268 100644
--- a/collects/framework/private/exit.ss
+++ b/collects/framework/private/exit.ss
@@ -1,14 +1,11 @@
 (module exit (lib "a-unit.ss")
   (require (lib "string-constant.ss" "string-constants")
-	   (lib "class.ss")
 	   "sig.ss"
-	   "../gui-utils.ss"
-	   (lib "mred-sig.ss" "mred")
-	   (lib "file.ss")
-           (lib "etc.ss"))
+	   "../preferences.ss"
+           "../gui-utils.ss"
+	   (lib "mred-sig.ss" "mred"))
 
-  (import mred^
-          [prefix preferences: framework:preferences^])
+  (import mred^)
   (export (rename framework:exit^
                   (-exit exit)))
       
diff --git a/collects/framework/private/finder.ss b/collects/framework/private/finder.ss
index 11e0274f..2807b45e 100644
--- a/collects/framework/private/finder.ss
+++ b/collects/framework/private/finder.ss
@@ -2,17 +2,14 @@
 (module finder (lib "a-unit.ss")
   (require (lib "string-constant.ss" "string-constants")
 	   "sig.ss"
-	   "../gui-utils.ss"
-           (lib "class.ss")
+           "../preferences.ss"
 	   (lib "mred-sig.ss" "mred")
 	   (lib "string.ss")
-	   (lib "list.ss")
 	   (lib "file.ss")
 	   (lib "etc.ss"))
 
 
   (import mred^
-          [prefix preferences: framework:preferences^]
           [prefix keymap: framework:keymap^])
 
   (export (rename framework:finder^
diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss
index 5e789f1b..9189713f 100644
--- a/collects/framework/private/frame.ss
+++ b/collects/framework/private/frame.ss
@@ -4,7 +4,8 @@
 	   (lib "class.ss")
 	   (lib "include.ss")
 	   "sig.ss"
-	   "../gui-utils.ss"
+	   "../preferences.ss"
+           "../gui-utils.ss"
            "bday.ss"
 	   (lib "mred-sig.ss" "mred")
 	   (lib "list.ss")
diff --git a/collects/framework/private/group.ss b/collects/framework/private/group.ss
index ecd96912..fd20aec2 100644
--- a/collects/framework/private/group.ss
+++ b/collects/framework/private/group.ss
@@ -3,7 +3,8 @@
   (require (lib "string-constant.ss" "string-constants")
            (lib "class.ss")
            "sig.ss"
-	   "../gui-utils.ss"
+	   "../preferences.ss"
+           "../gui-utils.ss"
            (lib "mred-sig.ss" "mred")
            (lib "list.ss")
            (lib "file.ss"))
@@ -11,7 +12,6 @@
   (import mred^
           [prefix application: framework:application^]
           [prefix frame: framework:frame^]
-          [prefix preferences: framework:preferences^]
           [prefix text: framework:text^]
           [prefix canvas: framework:canvas^]
           [prefix menu: framework:menu^])
diff --git a/collects/framework/private/handler.ss b/collects/framework/private/handler.ss
index b138bebd..9752f845 100644
--- a/collects/framework/private/handler.ss
+++ b/collects/framework/private/handler.ss
@@ -4,7 +4,8 @@
            (lib "list.ss")
            (lib "hierlist.ss" "hierlist")
 	   "sig.ss"
-	   "../gui-utils.ss"
+	   "../preferences.ss"
+           "../gui-utils.ss"
 	   (lib "mred-sig.ss" "mred")
 	   (lib "file.ss")
            (lib "string-constant.ss" "string-constants"))
@@ -14,7 +15,6 @@
           [prefix finder: framework:finder^]
           [prefix group: framework:group^]
           [prefix text: framework:text^]
-          [prefix preferences: framework:preferences^]
           [prefix frame: framework:frame^])
   (export framework:handler^)
   (init-depend framework:frame^)
diff --git a/collects/framework/private/keymap.ss b/collects/framework/private/keymap.ss
index ddb41405..e75908ef 100644
--- a/collects/framework/private/keymap.ss
+++ b/collects/framework/private/keymap.ss
@@ -5,11 +5,11 @@
 	   (lib "list.ss")
 	   (lib "mred-sig.ss" "mred")
            (lib "match.ss")
+           "../preferences.ss"
            "sig.ss")
   
    
   (import mred^
-          [prefix preferences: framework:preferences^]
           [prefix finder: framework:finder^]
           [prefix handler: framework:handler^]
           [prefix frame: framework:frame^]
diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss
index 6f63ab47..abb0da8c 100644
--- a/collects/framework/private/main.ss
+++ b/collects/framework/private/main.ss
@@ -1,9 +1,8 @@
 (module main (lib "a-unit.ss")
   (require (lib "class.ss")
 	   "sig.ss"
-	   "../gui-utils.ss"
-           (lib "string-constant.ss" "string-constants")
-	   (lib "mred-sig.ss" "mred"))
+           "../preferences.ss"
+   	   (lib "mred-sig.ss" "mred"))
   
   (import mred^
           [prefix preferences: framework:preferences^]
@@ -17,8 +16,10 @@
   (init-depend framework:preferences^ framework:exit^ framework:editor^
                framework:color-prefs^ framework:scheme^)
 
-      (application-preferences-handler (λ () (preferences:show-dialog)))
-      
+  (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)
diff --git a/collects/framework/private/menu.ss b/collects/framework/private/menu.ss
index a406225b..f4b7b4dd 100644
--- a/collects/framework/private/menu.ss
+++ b/collects/framework/private/menu.ss
@@ -1,10 +1,10 @@
 (module menu (lib "a-unit.ss")
   (require (lib "class.ss")
 	   "sig.ss"
-	   (lib "mred-sig.ss" "mred"))
+	   "../preferences.ss"
+           (lib "mred-sig.ss" "mred"))
   
-  (import mred^
-          [prefix preferences: framework:preferences^])
+  (import mred^)
   (export framework:menu^)
       
       (define can-restore<%>
diff --git a/collects/framework/private/number-snip.ss b/collects/framework/private/number-snip.ss
index c5047be6..53460550 100644
--- a/collects/framework/private/number-snip.ss
+++ b/collects/framework/private/number-snip.ss
@@ -3,10 +3,10 @@
   (require "sig.ss"
 	   (lib "mred-sig.ss" "mred")
 	   (lib "class.ss")
+           "../preferences.ss"
            (lib "string-constant.ss" "string-constants"))
   
-  (import mred^
-          [prefix preferences: framework:preferences^])
+  (import mred^)
   (export (rename framework:number-snip^
                   [-snip-class% snip-class%]))
   (init-depend mred^)
diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss
index cb7d8284..8e31257f 100644
--- a/collects/framework/private/preferences.ss
+++ b/collects/framework/private/preferences.ss
@@ -30,139 +30,18 @@ the state transitions / contracts are:
   (require (lib "string-constant.ss" "string-constants")
 	   (lib "class.ss")
            (lib "file.ss")
-	   (lib "etc.ss")
            "sig.ss"
            "../gui-utils.ss"
+           "../preferences.ss"
 	   (lib "mred-sig.ss" "mred")
-	   (lib "pretty.ss")
 	   (lib "list.ss"))
   
   (import mred^
-          [prefix exn: framework:exn^]
           [prefix exit: framework:exit^]
           [prefix panel: framework:panel^]
           [prefix frame: framework:frame^])
   (export framework:preferences^)
   
-  (define old-preferences-symbol 'plt:framework-prefs)
-  (define old-preferences (make-hash-table))
-  (let ([old-prefs (get-preference old-preferences-symbol (λ () '()))])
-    (for-each
-     (λ (line) (hash-table-put! old-preferences (car line) (cadr line)))
-     old-prefs))
-  
-  (define (add-pref-prefix p) (string->symbol (format "plt:framework-pref:~a" p)))
-  
-  ;; preferences : hash-table[sym -o> any]
-  ;; the current values of the preferences
-  (define preferences (make-hash-table))
-  
-  ;; marshalled : hash-table[sym -o> any]
-  ;; the values of the preferences, as read in from the disk
-  ;; each symbol will only be mapped in one of the preferences
-  ;; hash-table and this hash-table, but not both.
-  (define marshalled (make-hash-table))
-  
-  ;; marshall-unmarshall : sym -o> un/marshall
-  (define marshall-unmarshall (make-hash-table))
-  
-  ;; callbacks : sym -o> (listof (sym TST -> boolean))
-  (define callbacks (make-hash-table))
-  
-  ;; defaults : hash-table[sym -o> default]
-  (define defaults (make-hash-table))
-  
-  ;; these four functions determine the state of a preference
-  (define (pref-un/marshall-set? pref) (hash-table-bound? marshall-unmarshall pref))
-  (define (pref-default-set? pref) (hash-table-bound? defaults pref))
-  (define (pref-can-init? pref) 
-    (and (not snapshot-grabbed?)
-         (not (hash-table-bound? preferences pref))))
-  
-  ;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any))
-  (define-struct un/marshall (marshall unmarshall))
-  
-  ;; type pref = (make-pref any)
-  (define-struct pref (value))
-  
-  ;; type default  = (make-default any (any -> bool))
-  (define-struct default (value checker))
-  
-  ;; pref-callback : (make-pref-callback (union (weak-box (sym tst -> void)) (sym tst -> void)))
-  ;; this is used as a wrapped to deal with the problem that different procedures might be eq?.
-  (define-struct pref-callback (cb))
-  
-  ;; get : symbol -> any
-  ;; return the current value of the preference `p'
-  ;; exported
-  (define (get p)
-    (cond
-      [(pref-default-set? p)
-       
-       ;; unmarshall, if required
-       (when (hash-table-bound? marshalled p)
-         ;; if `preferences' is already bound, that means the unmarshalled value isn't useful.
-         (unless (hash-table-bound? preferences p)
-           (hash-table-put! preferences p (unmarshall-pref p (hash-table-get marshalled p))))
-         (hash-table-remove! marshalled p))
-       
-       ;; if there is no value in the preferences table, but there is one
-       ;; in the old version preferences file, take that:
-       (unless (hash-table-bound? preferences p)
-         (when (hash-table-bound? old-preferences p)
-           (hash-table-put! preferences p (unmarshall-pref p (hash-table-get old-preferences p)))))
-       
-       ;; clear the pref from the old table (just in case it was taking space -- we don't need it anymore)
-       (when (hash-table-bound? old-preferences p)
-         (hash-table-remove! old-preferences p))
-       
-       ;; if it still isn't set, take the default value
-       (unless (hash-table-bound? preferences p)
-         (hash-table-put! preferences p (default-value (hash-table-get defaults p))))
-       
-       (hash-table-get preferences p)]
-      [(not (pref-default-set? p))
-       (raise-unknown-preference-error
-        'preferences:get
-        "tried to get a preference but no default set for ~e"
-        p)]))
-  
-  ;; set : symbol any -> void
-  ;; updates the preference
-  ;; exported
-  (define (set p value) (multi-set (list p) (list value)))
-  
-  ;; set : symbol any -> void
-  ;; updates the preference
-  ;; exported
-
-  (define (multi-set ps values)
-    (for-each
-     (λ (p value)
-       (cond
-         [(pref-default-set? p)
-          (let ([default (hash-table-get defaults p)])
-            (unless ((default-checker default) value)
-              (error 'preferences:set
-                     "tried to set preference ~e to ~e but it does not meet test from preferences:set-default"
-                     p value))
-            (check-callbacks p value)
-            (hash-table-put! preferences p value)
-            (void))]
-         [(not (pref-default-set? p))
-          (raise-unknown-preference-error
-           'preferences:set "tried to set the preference ~e to ~e, but no default is set"
-           p
-           value)]))
-     ps values)
-    
-    (put-preferences/gui (map add-pref-prefix ps) 
-                         (map (λ (p value) (marshall-pref p value))
-                              ps
-                              values))
-    
-    (void))
-  
   (define (put-preferences/gui ps vs)
     (define (fail-func path)
       (let ([mb-ans
@@ -196,180 +75,9 @@ the state transitions / contracts are:
        ps
        vs
        fail-func)))
+  
+  
 
-  (define (raise-unknown-preference-error sym fmt . args)
-    (raise (exn:make-unknown-preference
-            (string-append (format "~a: " sym) (apply format fmt args))
-            (current-continuation-marks))))
-
-  ;; unmarshall-pref : symbol marshalled -> any
-  ;; unmarshalls a preference read from the disk
-  (define (unmarshall-pref p data)
-    (let/ec k
-      (let* ([unmarshall-fn (un/marshall-unmarshall
-                             (hash-table-get marshall-unmarshall
-                                             p
-                                             (λ () (k data))))]
-             [default (hash-table-get defaults p)]
-             [result (unmarshall-fn data)])
-        (if ((default-checker default) result)
-            result
-            (default-value default)))))
-  
-  ;; add-callback : sym (-> void) -> void
-  (define add-callback 
-    (opt-lambda (p callback [weak? #f])
-      (let ([new-cb (make-pref-callback (if weak?
-                                            (make-weak-box callback)
-                                            callback))])
-        (hash-table-put! callbacks
-                         p 
-                         (append 
-                          (hash-table-get callbacks p (λ () null))
-                          (list new-cb)))
-        (λ ()
-          (hash-table-put!
-           callbacks
-           p
-           (let loop ([callbacks (hash-table-get callbacks p (λ () null))])
-             (cond
-               [(null? callbacks) null]
-               [else 
-                (let ([callback (car callbacks)])
-                  (cond
-                    [(eq? callback new-cb)
-                     (loop (cdr callbacks))]
-                    [else
-                     (cons (car callbacks) (loop (cdr callbacks)))]))])))))))
-  
-  ;; check-callbacks : sym val -> void
-  (define (check-callbacks p value)
-    (let ([new-callbacks
-           (let loop ([callbacks (hash-table-get callbacks p (λ () null))])
-             (cond
-               [(null? callbacks) null]
-               [else 
-                (let* ([callback (car callbacks)]
-                       [cb (pref-callback-cb callback)])
-                  (cond
-                    [(weak-box? cb)
-                     (let ([v (weak-box-value cb)])
-                       (if v
-                           (begin 
-                             (v p value)
-                             (cons callback (loop (cdr callbacks))))
-                           (loop (cdr callbacks))))]
-                    [else
-                     (cb p value)
-                     (cons callback (loop (cdr callbacks)))]))]))])
-      (if (null? new-callbacks)
-          (hash-table-remove! callbacks p)
-          (hash-table-put! callbacks p new-callbacks))))
-  
-  (define (set-un/marshall p marshall unmarshall)
-    (cond
-      [(and (pref-default-set? p)
-            (not (pref-un/marshall-set? p))
-            (pref-can-init? p))
-       (hash-table-put! marshall-unmarshall p (make-un/marshall marshall unmarshall))]
-      [(not (pref-default-set? p))
-       (error 'preferences:set-un/marshall
-              "must call set-default for ~s before calling set-un/marshall for ~s"
-              p p)]
-      [(pref-un/marshall-set? p)
-       (error 'preferences:set-un/marshall
-              "already set un/marshall for ~e" 
-              p)]
-      [(not (pref-can-init? p))
-       (error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)]))
-  
-  (define (hash-table-bound? ht s)
-    (let/ec k
-      (hash-table-get ht s (λ () (k #f)))
-      #t))
-  
-  (define (restore-defaults)
-    (hash-table-for-each
-     defaults
-     (λ (p def) (set p (default-value def)))))
-  
-  ;; set-default : (sym TST (TST -> boolean) -> void
-  (define (set-default p default-value checker)
-    (cond
-      [(and (not (pref-default-set? p))
-            (pref-can-init? p))
-       (let ([default-okay? (checker default-value)])
-         (unless default-okay?
-           (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n"
-                  p checker default-okay? default-value))
-         (hash-table-put! defaults p (make-default default-value checker))
-         (let/ec k
-           (let ([m (get-preference (add-pref-prefix p) (λ () (k (void))))])
-             ;; if there is no preference saved, we just don't do anything.
-             ;; `get' notices this case.
-             (hash-table-put! marshalled p m))))]
-      [(not (pref-can-init? p))
-       (error 'preferences:set-default
-              "tried to call set-default for preference ~e but it cannot be configured any more"
-              p)]
-      [(pref-default-set? p)
-       (error 'preferences:set-default
-              "preferences default already set for ~e" p)]
-      [(not (pref-can-init? p))
-       (error 'preferences:set-default
-              "can no longer set the default for ~e" p)]))
-  
-  ;; marshall-pref : symbol any -> (list symbol printable)
-  (define (marshall-pref p value)
-    (let/ec k
-      (let* ([marshaller
-              (un/marshall-marshall
-               (hash-table-get marshall-unmarshall p (λ () (k value))))])
-        (marshaller value))))
-  
-  (define (read-err input msg)
-    (message-box 
-     (string-constant preferences)
-     (let* ([max-len 150]
-            [s1 (format "~s" input)]
-            [ell "..."]
-            [s2 (if (<= (string-length s1) max-len)
-                    s1
-                    (string-append
-                     (substring s1 0 (- max-len
-                                        (string-length ell)))
-                     ell))])
-       (string-append
-        (string-constant error-reading-preferences)
-        "\n"
-        msg
-        "\n"
-        s2))))
-  
-  (define snapshot-grabbed? #f)
-  (define (get-prefs-snapshot)
-    (set! snapshot-grabbed? #t)
-    (hash-table-map defaults (λ (k v) (cons k (get k)))))
-    
-  (define (restore-prefs-snapshot snapshot)
-    (multi-set (map car snapshot)
-               (map cdr snapshot)))
-  
-  
-  ;;    ;           ;;;                 
-  ;                  ;                 
-  ;                  ;                 
-  ;;;;  ;;;    ;;;;     ;     ;;;    ;;; ;
-  ;   ;    ;        ;    ;    ;   ;  ;   ; 
-  ;   ;    ;     ;;;;    ;    ;   ;  ;   ; 
-  ;   ;    ;    ;   ;    ;    ;   ;  ;   ; 
-  ;   ;    ;    ;   ;    ;    ;   ;  ;   ; 
-  ;;; ; ;;;;;   ;;; ; ;;;;;;  ;;;    ;;;; 
-  ; 
-  ; 
-  ;;;  
-  
-  
   ;; ppanel-tree = 
   ;;  (union (make-ppanel-leaf string (union #f panel) (panel -> panel))
   ;;         (make-ppanel-interior string (union #f panel) (listof panel-tree)))
@@ -465,12 +173,12 @@ the state transitions / contracts are:
   (define can-close-dialog-callbacks null)
   
   (define (make-preferences-dialog)
-    (letrec ([stashed-prefs (get-prefs-snapshot)]
+    (letrec ([stashed-prefs (preferences:get-prefs-snapshot)]
              [frame-stashed-prefs%
               (class frame:basic%
                 (define/override (show on?)
                   (when on?
-                    (set! stashed-prefs (get-prefs-snapshot)))
+                    (set! stashed-prefs (preferences:get-prefs-snapshot)))
                   (super show on?))
                 (super-new))]
              [frame 
@@ -529,7 +237,7 @@ the state transitions / contracts are:
                               (hide-dialog)))]
              [cancel-callback (λ (_1 _2)
                                 (hide-dialog)
-                                (restore-prefs-snapshot stashed-prefs))])
+                                (preferences:restore-prefs-snapshot stashed-prefs))])
       (gui-utils:ok/cancel-buttons
        bottom-panel
        ok-callback
@@ -574,14 +282,15 @@ the state transitions / contracts are:
   (define (make-check main pref title bool->pref pref->bool)
     (let* ([callback
             (λ (check-box _)
-              (set pref (bool->pref (send check-box get-value))))]
-           [pref-value (get pref)]
+              (preferences:set pref (bool->pref (send check-box get-value))))]
+           [pref-value (preferences:get pref)]
            [initial-value (pref->bool pref-value)]
            [c (make-object check-box% title main callback)])
       (send c set-value initial-value)
-      (add-callback pref
-                    (λ (p v)
-                      (send c set-value (pref->bool v))))))
+      (preferences:add-callback
+       pref
+       (λ (p v)
+         (send c set-value (pref->bool v))))))
   
   (define (make-recent-items-slider parent)
     (let ([slider (instantiate slider% ()
@@ -589,11 +298,11 @@ the state transitions / contracts are:
                     (label (string-constant number-of-open-recent-items))
                     (min-value 1)
                     (max-value 100)
-                    (init-value (get 'framework:recent-max-count))
+                    (init-value (preferences:get 'framework:recent-max-count))
                     (callback (λ (slider y)
-                                (set 'framework:recent-max-count
-                                     (send slider get-value)))))])
-      (add-callback
+                                (preferences:set 'framework:recent-max-count
+                                                 (send slider get-value)))))])
+      (preferences:add-callback
        'framework:recent-max-count
        (λ (p v)
          (send slider set-value v)))))
@@ -732,13 +441,14 @@ the state transitions / contracts are:
               (λ (family)
                 (let ([name (build-font-preference-symbol family)]
                       [font-entry (build-font-entry family)])
-                  (set-default name
-                               default
-                               (cond
-                                 [(string? default) string?]
-                                 [(number? default) number?]
-                                 [else (error 'internal-error.set-default "unrecognized default: ~a~n" default)]))
-                  (add-callback 
+                  (preferences:set-default
+                   name
+                   default
+                   (cond
+                     [(string? default) string?]
+                     [(number? default) number?]
+                     [else (error 'internal-error.set-default "unrecognized default: ~a~n" default)]))
+                  (preferences:add-callback 
                    name 
                    (λ (p new-value)
                      (write-resource 
@@ -773,11 +483,11 @@ the state transitions / contracts are:
                             [set-edit-font
                              (λ (size)
                                (let ([delta (make-object style-delta% 'change-size size)]
-                                     [face (get pref-sym)])
+                                     [face (preferences:get pref-sym)])
                                  (if (and (string=? face font-default-string)
                                           family-const-pair)
                                      (send delta set-family (cadr family-const-pair))
-                                     (send delta set-delta-face (get pref-sym)))
+                                     (send delta set-delta-face (preferences:get pref-sym)))
                                  
                                  (send edit change-style delta 0 (send edit last-position))))]
                             
@@ -807,14 +517,14 @@ the state transitions / contracts are:
                                                  name)
                                          fonts)])
                                    (when new-value
-                                     (set pref-sym (list-ref fonts (car new-value))) 
-                                     (set-edit-font (get font-size-pref-sym))))))]
+                                     (preferences:set pref-sym (list-ref fonts (car new-value))) 
+                                     (set-edit-font (preferences:get font-size-pref-sym))))))]
                             [canvas (make-object editor-canvas% horiz
                                       edit
                                       (list 'hide-hscroll
                                             'hide-vscroll))])
-                       (set-edit-font (get font-size-pref-sym))
-                       (add-callback
+                       (set-edit-font (preferences:get font-size-pref-sym))
+                       (preferences:add-callback
                         pref-sym
                         (λ (p new-value)
                           (send horiz change-children
@@ -861,11 +571,11 @@ the state transitions / contracts are:
                      1 127
                      size-panel
                      (λ (slider evt)
-                       (set font-size-pref-sym (send slider get-value)))
+                       (preferences:set font-size-pref-sym (send slider get-value)))
                      initial-font-size)])
            (update-message-sizes font-message-get-widths font-message-user-min-sizes)
            (update-message-sizes category-message-get-widths category-message-user-min-sizes)
-           (add-callback
+           (preferences:add-callback
             font-size-pref-sym
             (λ (p value)
               (for-each (λ (f) (f value)) set-edit-fonts)
diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss
index 871ad8a3..b73c0e1e 100644
--- a/collects/framework/private/scheme.ss
+++ b/collects/framework/private/scheme.ss
@@ -7,13 +7,11 @@
 	   (lib "class.ss")
 	   "sig.ss"
 	   (lib "mred-sig.ss" "mred")
-           (lib "mred.ss" "mred")
 	   (lib "list.ss")
-	   (lib "thread.ss")
            (lib "etc.ss")
-           (lib "surrogate.ss")
            (lib "scheme-lexer.ss" "syntax-color")
-           "../gui-utils.ss")
+           "../gui-utils.ss"
+           "../preferences.ss")
   
   
   (import mred^
diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss
index 9e8c4c05..2338956b 100644
--- a/collects/framework/private/sig.ss
+++ b/collects/framework/private/sig.ss
@@ -60,12 +60,6 @@
   (define-signature panel^ extends panel-class^
     ())
 
-  (define-signature exn-class^
-    ())
-  (define-signature exn^ extends exn-class^
-    ((struct exn ())
-     (struct unknown-preference ())))
-
   (define-signature application-class^
     ())
   (define-signature application^ extends application-class^
@@ -74,14 +68,7 @@
   (define-signature preferences-class^
     ())
   (define-signature preferences^ extends preferences-class^
-    (get
-     add-callback
-     set
-     set-default
-     set-un/marshall
-
-     restore-defaults
-     
+    (put-preferences/gui
      add-panel
      add-font-panel
 
@@ -436,7 +423,6 @@
     ((open (prefix application: application^))
      (open (prefix version: version^))
      (open (prefix color-model: color-model^))
-     (open (prefix exn: exn^))
      (open (prefix mode: mode^))
      (open (prefix exit: exit^))
      (open (prefix menu: menu^))
diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss
index 5d2b8050..71e24e25 100644
--- a/collects/framework/private/text.ss
+++ b/collects/framework/private/text.ss
@@ -11,7 +11,8 @@ WARNING: printf is rebound in the body of the unit to always
            (lib "match.ss")
 	   "sig.ss"
 	   "../gui-utils.ss"
-	   (lib "mred-sig.ss" "mred")
+	   "../preferences.ss"
+           (lib "mred-sig.ss" "mred")
            (lib "interactive-value-port.ss" "mrlib")
 	   (lib "list.ss")
 	   (lib "etc.ss"))
@@ -19,7 +20,6 @@ WARNING: printf is rebound in the body of the unit to always
   (import mred^
           [prefix icon: framework:icon^]
           [prefix editor: framework:editor^]
-          [prefix preferences: framework:preferences^]
           [prefix keymap: framework:keymap^]
           [prefix color-model: framework:color-model^]
           [prefix frame: framework:frame^]